import Cube.Simple.Basic
import Cube.Simple.Infer
import Cube.Simple.Eval

open Lean
namespace Cube.Simple.Expr

namespace Unify

inductive Head where
| const (name : String)
| bvar (idx : Nat)
| fvar (fvarId : FVarId)
deriving DecidableEq, Hashable, Inhabited, Repr

structure BetaEtaNormalExpr where
  binder : Array Ty
  head : Head
  args : Array Expr
deriving DecidableEq, Hashable, Inhabited, Repr

def BetaEtaNormalExpr.ofNormalExpr (expr : Expr) : BetaEtaNormalExpr :=
  let (binder, body) := lambdaTelescope expr
  let (args, head) := appTelescope body
  let head := match head with
    | .const name => .const name
    | .bvar idx => .bvar idx
    | .fvar fvarId => .fvar fvarId
    | _ => panic! "Not in correct normal form"
  { binder, head, args }

def BetaEtaNormalExpr.ofExpr (expr : Expr) (ty : Ty) : BetaEtaNormalExpr :=
  .ofNormalExpr <| betaEtaNormalForm expr ty

def Head.toExpr (head : Head) : Expr :=
  match head with
  | .const name => .const name
  | .bvar idx => .bvar idx
  | .fvar fvarId => .fvar fvarId

def BetaEtaNormalExpr.toExpr (expr : BetaEtaNormalExpr) : Expr :=
  let body := mkApp expr.head.toExpr expr.args
  abstractArgs body expr.binder

inductive Flexibility where
| rigid
| flexible

def BetaEtaNormalExpr.flexibility (expr : BetaEtaNormalExpr) : Flexibility :=
  match expr.head with
  | .fvar .. => .flexible
  | _ => .rigid

theorem BetaEtaNormalExpr.False_of_rigid_fvar {expr : BetaEtaNormalExpr} (h1 : expr.flexibility = .rigid) (h2 : expr.head = .fvar fvarId) : False := by
  unfold flexibility at h1
  rw [h2] at h1
  simp at h1

def BetaEtaNormalExpr.headType (expr : BetaEtaNormalExpr) : SimpleM Ty := do
  match expr.head with
  | .const name => return (← read).find! name
  | .fvar fvarId => return (← get).find! fvarId
  | .bvar idx => return expr.binder.get! (expr.binder.size - idx)

def inhabitant (ty : Ty) : Expr :=
  match ty with
  | .nat => .const "0"
  | .fun t1 t2 => .lam t1 (inhabitant t2)

def BetaEtaNormalExpr.headFVarId (expr : BetaEtaNormalExpr) (h : expr.flexibility = .flexible) : FVarId :=
  match h2:expr.head with
  | .fvar fvarId => fvarId
  | .bvar idx | .const name => by simp [flexibility, h2] at h

def BetaEtaNormalExpr.applySubst (normalExpr : BetaEtaNormalExpr) (subst : Substitution) : SimpleM BetaEtaNormalExpr := do
  let expr := normalExpr.toExpr
  let substExpr := expr.applySubst subst
  let ty ← infer substExpr
  return BetaEtaNormalExpr.ofExpr substExpr ty

abbrev DisagreementPair := BetaEtaNormalExpr × BetaEtaNormalExpr
abbrev DisagreementSet := HashSet DisagreementPair
structure UnifyNode where
  disagreement : DisagreementSet
  substitution : Substitution

def DisagreementPair.apply (pair : DisagreementPair) (subst : Substitution) : SimpleM DisagreementPair :=
  return (← pair.fst.applySubst subst, ← pair.snd.applySubst subst)

def DisagreementSet.apply (set : DisagreementSet) (subst : Substitution) : SimpleM DisagreementSet :=
  set.foldM (init := HashSet.empty) (fun new pair => do return new.insert (← pair.apply subst))

def UnifyNode.apply (node : UnifyNode) (subst : Substitution) : SimpleM UnifyNode := do
  return ⟨← node.disagreement.apply subst, node.substitution.compose subst⟩

-- https://www21.in.tum.de/teaching/sar/SS20/5.pdf
partial def unify (e1 e2 : Expr) : SimpleM Substitution := do
  let t1 ← infer e1
  let t2 ← infer e2
  if t1 == t2 then
    let e1Normal := BetaEtaNormalExpr.ofExpr e1 t1
    let e2Normal := BetaEtaNormalExpr.ofExpr e2 t1
    go [⟨HashSet.empty.insert (e1Normal, e2Normal), {}⟩]
  else
    throw "Types don't match"
where
  go (state : List UnifyNode) : SimpleM Substitution := do
    match state with
    | [] => throw "Gave up after exhaustive search"
    | node :: rest =>
      match ← simplify node with
      | none => go rest
      | some (.inl subst) => return subst
      | some (.inr node) =>
        match findMatcherTarget node.disagreement with
        | some (lhs, rhs) =>
          let candidates ← matcher lhs rhs
          let newNodes ← candidates.mapM node.apply
          go <| rest.append newNodes
        | none => go <| rest.append [node]

  simplify (node : UnifyNode) : SimpleM (Option (Substitution ⊕ UnifyNode)) := do
    let mut newSet := HashSet.empty
    let mut newSubst := node.substitution
    for pair in node.disagreement do
      match ← simplifyPair pair newSubst with
      | none => return none
      | some (.inl subst) => newSubst := subst
      | some (.inr set) => newSet := newSet.merge set
    if newSet.isEmpty then
      return some <| .inl newSubst
    else
      return some <| .inr ⟨newSet, newSubst⟩

  simplifyPair (pair : DisagreementPair) (subst : Substitution) : SimpleM (Option (Substitution ⊕ DisagreementSet)) := do
    let lhs := pair.fst
    let rhs := pair.snd
    match hlflex:lhs.flexibility, hrflex:rhs.flexibility with
    | .rigid, .rigid =>
      if lhs.binder != rhs.binder || lhs.head != rhs.head then
        return none
      else
        let newProblems := lhs.args.zip rhs.args
        let folder := fun set (newLhs, newRhs) =>
          let newLhs := BetaEtaNormalExpr.ofNormalExpr newLhs
          let newRhs := BetaEtaNormalExpr.ofNormalExpr newRhs
          let newPair := ⟨{newLhs with binder := lhs.binder.append newLhs.binder}, {newRhs with binder := rhs.binder.append newRhs.binder}⟩
          set.insert newPair
        let newDisagreements := newProblems.foldl (init := .empty) folder
        return some <| .inr newDisagreements
    | .flexible, .flexible =>
      let lhsVal := inhabitant (← lhs.headType)
      let rhsVal := inhabitant (← rhs.headType)
      let subst := subst.insert (lhs.headFVarId hlflex) lhsVal
        |>.insert (rhs.headFVarId hrflex) rhsVal
      return some <| .inl subst
    | .flexible, .rigid => return some <| .inr <| HashSet.empty.insert (lhs, rhs)
    | .rigid, .flexible => return some <| .inr <| HashSet.empty.insert (rhs, lhs)

  findMatcherTarget (set : DisagreementSet) : Option ({ e : BetaEtaNormalExpr // e.flexibility = .flexible} × { e : BetaEtaNormalExpr // e.flexibility = .rigid}) := do
    for (lhs, rhs) in set do
      match hlflex:lhs.flexibility, hrflex:rhs.flexibility with
      -- simplify already turned .rigid, .flexible this way around
      | .flexible, .rigid => return (⟨lhs, hlflex⟩, ⟨rhs, hrflex⟩)
      | _, _ => pure ()
    none

  projection (binder : Array Ty) (targetFVar : FVarId) (z : Nat) (zTelescope : Array Ty) : SimpleM Substitution := do
    let mut hs := #[]
    -- TODO this opt should be possible below as well
    let args := (zTelescope.size - 1).fold (init := #[]) (fun idx args => args.push (.bvar idx))
    -- TODO Dedup with projection
    for hResTy in zTelescope[:zTelescope.size - 1] do
      let hTyTelescope := binder.push hResTy
      let hTy := Ty.ofTelescope hTyTelescope
      let hFVar ← FVar.freshM hTy
      let hTerm := mkApp (.fvar hFVar) args
      hs := hs.push hTerm
    let replacer := abstractArgs (mkApp (.bvar z) hs) zTelescope
    let candidate := (Substitution.empty.insert targetFVar replacer)
    return candidate

  projections (e : BetaEtaNormalExpr) (targetFVar : FVarId) (targetFVarTyTelescope : Array Ty) (resultTy : Ty) : SimpleM (List Substitution) := do
    let mut substs := []
    for i in [0:targetFVarTyTelescope.size - 1] do
      let iTy := targetFVarTyTelescope[i]!
      let iTyTelescope := iTy.telescope
      let iResultTy := iTyTelescope[iTyTelescope.size - 1]!
      if resultTy == iResultTy then
        substs := (← projection e.binder targetFVar i iTyTelescope) :: substs
    return substs

  matcher (flex : { e : BetaEtaNormalExpr // e.flexibility = .flexible}) (rig : { e : BetaEtaNormalExpr // e.flexibility = .rigid}) : SimpleM (List Substitution) := do
    let targetFVar := flex.val.headFVarId flex.property
    let targetFVarTyTelescope := (← getCtx).find! targetFVar |>.telescope
    match hhead:rig.val.head with
    | .bvar idx => projections flex.val targetFVar targetFVarTyTelescope (rig.val.binder.get! (rig.val.binder.size - idx))
    | .const name =>
      -- imitation
      let mut hs := #[]
      let constTy := (← getEnv).find! name
      let constTyTelescope := constTy.telescope
      for hResTy in constTyTelescope[:constTyTelescope.size - 1] do
        let hTyTelescope := targetFVarTyTelescope.set! (targetFVarTyTelescope.size - 1) hResTy
        let hTy := Ty.ofTelescope hTyTelescope
        let args := (hTyTelescope.size - 1).fold (init := #[]) (fun idx args => args.push (.bvar idx))
        let hFVar ← FVar.freshM hTy
        let hTerm := mkApp (.fvar hFVar) args
        hs := hs.push hTerm
      let replacer := abstractArgs (mkApp (.const name) hs) (targetFVarTyTelescope[:targetFVarTyTelescope.size - 1])
      let candidates := (Substitution.empty.insert targetFVar replacer) :: (← projections flex.val targetFVar targetFVarTyTelescope (constTyTelescope.get! (constTyTelescope.size - 1)))
      -- TODO: Projection
      return candidates
    | .fvar .. => nomatch BetaEtaNormalExpr.False_of_rigid_fvar rig.property hhead

#eval show IO _ from do
  let testPairs := #[
    -- flexible, flexible
    ([stlc| λ a : ℕ . f a], [stlc| λ b : ℕ . x], Env.empty, (Context.empty.insert ⟨"f", 0⟩ (.fun .nat .nat) |>.insert ⟨"x", 0⟩ .nat)),
    -- rigid, rigid
    ([stlc| λ f : ℕ → ℕ . f x], [stlc| λ g : ℕ → ℕ . g x], Env.empty, (Context.empty.insert ⟨"x", 0⟩ .nat)),
    -- flexible, rigid
    ([stlc| λ y : ℕ . x], [stlc| λ y : ℕ . 0], (Env.empty.insert "0" .nat), (Context.empty.insert ⟨"x", 0⟩ .nat)),
    ([stlc| λ x : ℕ . f x], [stlc| λ y : ℕ . 0], (Env.empty.insert "0" .nat), (Context.empty.insert ⟨"f", 0⟩ (.fun .nat .nat))),
    ([stlc| λ x : ℕ . f x], [stlc| λ y : ℕ . C y], (Env.empty.insert "C" (.fun .nat .nat)), (Context.empty.insert ⟨"f", 0⟩ (.fun .nat .nat))),
    ([stlc| λ x : ℕ . f (C (f x))], [stlc| λ x : ℕ . C x], (Env.empty.insert "C" (.fun .nat .nat)), (Context.empty.insert ⟨"f", 0⟩ (.fun .nat .nat)))
  ]
  for (expr1, expr2, env, ctx) in testPairs do
    let subst := unify expr1 expr2 |>.run' env ctx
    match subst with
    | .ok subst =>
      let expr1' := expr1.applySubst subst |>.betaReduce
      let expr2' := expr2.applySubst subst |>.betaReduce
      IO.println s!"{repr subst}"
      IO.println s!"{repr expr1'}"
      IO.println s!"{repr expr2'}"
      IO.println ""
    | .error e => IO.println s!"unification failure: {e} \n"

end Cube.Simple.Expr.Unify


import LMT

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

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


import Contractome.EVM

open EVM

variable {C : Cfg} [DecidableEq C.Tw] [∀ n, OfNat C.Tw n] [Element C.Tw] [DecidableEq C.Tb] [∀ n, OfNat C.Tb n] [Element C.Tb]
variable [TakeBytes C.BAI]
variable [instBA : SByteArray C.Tw C.Tb C.BA C.BAI]
variable [EVMStack C.Tw C.S] [EVMStack (C.Tw × C.BA) C.RS] [EVMMapDefault C.Tw C.Tw C.AM] [EVMMapSeq C.Tw C.Tb C.BA C.BAI C.M]
variable [EVMMapBasic C.Tw C.BA C.BAM]
variable [Zero C.M]
variable [EVMMapDefault C.Tw C.M C.STM]
variable [Repr C.Tw] [Repr C.Tb] [Repr C.M] [Repr C.S] [Repr C.BA] [Repr C.BAM] [Repr C.AM] [Repr C.BA] [Repr C.STM] [Repr C.RS]

variable {c : Context (C:=C)}

set_option quotPrecheck false
syntax:67 term " b:: " term : term

macro_rules
  | `($a:term b:: $b:term)  => `(EVMStack.push (S:=C.S) $b $a)

-- syntax "b[" sepBy(term, ", ") "]" : term

-- macro_rules
--   | `(b[ $elems,* ]) => `(ByteArray.mk #[ $elems,* ])

-- #print simp

def p (x y : Nat) := x = y

-- example (x y : Nat) : p (x + y) (0 + y + x) := by
--   conv =>
--     whnf
--     rhs
--     rw [Nat.zero_add, Nat.add_comm]
--     trace_state
--     skip
--     done

-- abbrev optimistic_2stack_op {stackRest : C.S} {v1 v2 : C.Tw} (op : C.Tw -> C.Tw -> C.Tw) (opName : EVMM (C:=C) Unit)
--   (hS : (c.stack = v1 b:: v2 b:: stackRest)) (post : EVMM (C:=C) α) :=
--   EVMM.runWithC (C:=C) (do opName; post) c =
--   EVMM.runWithC (C:=C) (post) {c with stack := (op v1 v2) b:: stackRest}

abbrev optimistic_2stack_op_s {stackRest : C.S} {v1 v2 : C.Tw}
  {op : C.Tw -> C.Tw -> C.Tw} (opName : EVMM (C:=C) Unit) (hOp : opName = EVMM.mapStack2 op)
  (hS : (c.stack = v1 b:: v2 b:: stackRest)) (post : EVMM (C:=C) α) :=
  EVMM.runWithC (C:=C) (do opName; post) c =
  EVMM.runWithC (C:=C) (post) {c with stack := (op v1 v2) b:: stackRest}

theorem optimistic_2stack_op {stackRest : C.S} {v1 v2 : C.Tw}
  {op : C.Tw -> C.Tw -> C.Tw} (opName : EVMM (C:=C) Unit) (hOp : opName = EVMM.mapStack2 op)
  (hS : (c.stack = v1 b:: v2 b:: stackRest)) (post : EVMM (C:=C) α) :
  EVMM.runWithC (C:=C) (do opName; post) c =
  EVMM.runWithC (C:=C) (post) {c with stack := (op v1 v2) b:: stackRest} :=
  by
      cases c
      simp only at *
      subst hS
      subst hOp
      conv =>
        simp [EVMM.runWithC, EVMM.mapStack2, EVMM.popStack]

abbrev optimistic_i01_add := optimistic_2stack_op (C:=C) (opName:=EVMM.i01_add) (op:=Element.add) (hOp := rfl)

theorem optimistic_add {stackRest : C.S} {v1 v2 : C.Tw} (hS : (c.stack = v1 b:: v2 b:: stackRest)) (post : EVMM (C:=C) α) :
  EVMM.runWithC (C:=C) (do EVMM.i01_add; post) c =
  EVMM.runWithC (C:=C) (post) {c with stack := (Element.add v1 v2) b:: stackRest}
  := by
    cases c
    simp only at *
    subst hS
    conv =>
      simp [EVMM.i01_add, EVMM.runWithC, EVMM.mapStack2, EVMM.popStack]

-- set_option trace.Debug.Meta.Tactic.simp true
theorem test {stackRest : C.S} {v : C.Tw} (hS : (c.stack = v b:: stackRest)) :
  EVMM.runWithC (C:=C) (EVMM.popStack) c = Except.ok (v, {c with stack := stackRest}) := by
  simp [EVMM.runWithC, StateT.run, ExceptT.run]
  cases c
  simp at *
  subst hS
  -- simp [EVMM.popStack]
  unfold EVMM.popStack
  -- simp
  -- simp
  conv =>
    lhs
    whnf
    simp

#eval 5

  -- simp (config := {zeta := false, beta := false, eta := false, etaStruct := false, iota := false, proj := false, decide := false, memoize := false})
  -- simp only [get]
  -- simp at *

-- theorem test {stackRest : C.S} {v1 v2 : C.Tw} (hS : (c.stack = v1 b:: v2 b:: stackRest)) :
--   EVMM.runWithC (C:=C) (EVMM.i01_add) tC cC c = Except.error EVMException.abstractValueError := by
--   simp [EVMM.runWithC, StateT.run, ExceptT.run, EVMM.i01_add]
--   unfold EVMM.mapStack2
--   unfold EVMM.popStack
  -- simp


import LMT

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

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


import .rules

open psum nnf node

set_option eqn_compiler.zeta true

def tableau : Π Γ : sseqt, node Γ
| Γ :=
  match get_contra_seqt Γ with
  | inl w := contra_rule_seqt w.2
  | inr no_contra :=
    match get_and_seqt Γ with
    | inl w :=
    let inst := and_instance_seqt.cons w.2 in
    have h : prod.measure_lex' sseqt_size (and_child Γ w.2) Γ,
    begin apply split_lt_and_seqt end,
    let d_delta := tableau (and_child Γ w.2) in
    and_rule_seqt inst d_delta
    | inr no_and :=
      match get_or_seqt Γ with
      | inl w :=
      let inst := or_instance_seqt.cons w.2 in
      have h₁ : prod.measure_lex' sseqt_size (or_child_left Γ w.2) Γ,
      begin apply split_lt_or_seqt_left end,
      have h₂ : prod.measure_lex' sseqt_size (or_child_right Γ w.2) Γ,
      begin apply split_lt_or_seqt_right end,
      let Γ₁ := tableau (or_child_left Γ w.2) in
      match Γ₁ with
      | closed p := or_rule_seqt inst (closed p) (tableau (or_child_right Γ w.2))
      | open_ w := open_rule_seqt inst w.2
      end
      | inr no_or :=
        match get_box_seqt Γ with
        | inl w := -- term mode here helps termination
        if hb : box w.1 ∈ Γ.b then
        let inst := box_dup_instance_seqt.cons w.2 hb in
        have h : prod.measure_lex' sseqt_size (box_child Γ w.2) Γ,
        from copy_lt_seqt _ _,
        let d_delta := tableau (box_child Γ w.2) in
        box_rule_seqt inst d_delta
        else
        let inst := box_new_instance_seqt.cons w.2 hb in
        have h : prod.measure_lex' sseqt_size (box_child_new Γ w.2 hb) Γ,
        from box_new_lt_seqt _ _ _,
        let d_delta := tableau (box_child_new Γ w.2 hb) in
        box_new_rule_seqt inst d_delta
        | inr no_box :=
          match get_dia_seqt Γ with
          | inl w :=
          let ma : modal_applicable Γ :=
              {satu := {no_and := no_and, no_or := no_or},
               no_contra_main := no_contra,
               no_box_main := no_box,
               φ := w.1,
               ex := w.2} in
          let l := @dia_rule_seqt (λ Δ, prod.measure_lex' sseqt_size Δ Γ)
                   (λ x h, tableau x) (unmodal_seqt Γ)
                   (unmodal_seqt_size Γ) in
            match l with
            | inl w := begin left, exact unsat_of_unsat_unmodal w.1 w.2 end
            | inr w :=
            begin
            right, split, swap,
            {let lm := models_to_tmodels w.1,
             let sgm := dia_rule_loop Γ.h Γ.b Γ.m,
             let mΓ : sseqt := Γ,
             let mhtk := Γ.m,
             have mhhtk : hintikka Γ.m, {apply hintikka_ma ma},
             have mmhtk : Γ.m ⊆ Γ.m, {simp},
             split, swap,
             {let minfo : info := ⟨mΓ, mhtk, mhhtk, mmhtk⟩,
              exact tmodel.cons minfo lm sgm },
             {split,
              {split,
               {simp, intros s hs, have := list.mem_map.1 hs,
                rcases this with ⟨i, hmem, hi⟩, intros φ hφ, rw ←hi,
                apply mem_be_box, exact w.2, exact hmem, exact hφ},
               {simp, intros s hs φ hφ, exfalso, apply no_box, exact hφ},
               {simp, intros φ hφ,
                by_cases hc : φ ∈ Γ.h,
                {left, have := mem_loop_left _ Γ.b _  _ hc hφ, split, split, exact this, simp},
                {right, have := mem_be_dia _ _ w.2 _ hφ hc,
                 rcases this with ⟨i, hmem, hi⟩,
                 have := list.mem_map_of_mem (λ x : model, x.val) hmem,
                 split, split, exact this, exact hi} },
               {simp, intros s rq hdesc hmem,
                have := ex_desc' _ _ lm _ hdesc,
                cases this with hl hr,
                {have hc := list.mem_map.1 hl,
                 rcases hc with ⟨ms, pmsl, pmsr⟩,
                 have hci := be_ex _ _ w.2 _ pmsl,
                 rcases hci with ⟨iw, imem, pi⟩,
                 have ps := pt_of_m_to_tm _ _ hl,
                 have hsub := ps.1.sreq,
                 cases s with is ls sgs,
                 simp at hmem, simp at hsub,
                 have hin := hsub hmem,
                 rw pmsr at pi, simp at pi, rw pi at hin,
                 have := unmodal_sig _ _ imem _ hin,
                 cases this,
                 {right, split, swap, exact tmodel.cons is ls sgs, split, exact hdesc, simp, rw this, rw pi},
                 {left, exact this}},
                {rcases hr with ⟨c, memc, pdc⟩,
                 have pc := pt_of_m_to_tm _ _ memc,
                 have := pc.1.bdia,
                 cases c with ic lc sgc, simp at this,
                 have hc := this _ _ pdc hmem,
                 cases hc with hl hr,
                 {have hcc := list.mem_map.1 memc,
                  rcases hcc with ⟨ms, pmsl, pmsr⟩,
                  have hci := be_ex _ _ w.2 _ pmsl,
                  rcases hci with ⟨iw, imem, pi⟩,
                  have ps := pt_of_m_to_tm _ _ memc,
                  rw pmsr at pi, simp at pi, rw pi at hl,
                  have hccc := unmodal_sig _ _ imem _ hl,
                  cases hccc,
                  {right, split, swap, exact tmodel.cons ic lc sgc, split, apply tc'.base, simp, exact memc, simp, rw hccc, rw pi},
                  {left, exact hccc} },
                 {right,
                  rcases hr with ⟨d, ddesc, hd⟩,
                  split, swap, exact d, split,
                  {apply desc_ex, split, split, exact memc, exact ddesc},
                  {exact hd}}}},
               {simp, intros rq hrq φ hφ, cases hφ,
                {exfalso, apply ma.no_box_main, exact hφ},
                {have := mem_loop_box _ _ _ _ hrq, rw this, exact hφ}},
               {simp, intros s hs, have := mem_loop_dia _ _ _ _ hs,
                rcases this with ⟨w, hmem, hw⟩,
                have := Γ.ha _ hmem,
                have sb := mem_loop_box _ _ _ _ hs,
                cases s, rw ←hw at this, rw ←sb at this, simp at this, exact this}},
              {intros d hd, have := ex_desc' _ _ _ _ hd,
               cases this,
               {have pd := pt_of_m_to_tm _ _ this, exact pd.1},
               {rcases this with ⟨m, memm, mdesc⟩,
                have pd := pt_of_m_to_tm _ _ memm,
                apply pd.2, exact mdesc}}}},
            {simp}
            end
          end
          | inr no_dia :=
          let mc : model_constructible Γ :=
            {satu := {no_and := no_and, no_or := no_or},
             no_box_main := no_box,
             no_contra_main := no_contra,
             no_dia := no_dia} in build_model mc
          end
        end
      end
    end
  end
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, prod.measure_lex_wf' sseqt_size⟩], dec_tac := `[assumption]}

@[simp] def mk_sseqt (Γ : list nnf) : sseqt :=
{ goal := Γ,
  s := none,
  a := [],
  h := [],
  b := [],
  m := Γ,
  ndh := list.nodup_nil,
  ndb := list.nodup_nil,
  sph := list.nil_subperm,
  spb := list.nil_subperm,
  sbm := mem_closure_self _,
  ha := λ x hx, absurd hx $ list.not_mem_nil _,
  hb := box_only_nil,
  ps₁ := λ h, by contradiction,
  ps₂ := λ h, by contradiction }

def is_sat (Γ : list nnf) : bool :=
match tableau (mk_sseqt Γ) with
| closed _ := ff
| open_ _ := tt
end

theorem model_existence (m : model) (hrt : manc m.1 = [])
(Γ : list nnf) (h : Γ ⊆ htk m.1) : ∃ (st : Type) (k : S4 st) s, sat k s Γ :=
begin
split, swap,
exact {x : rmodel // x.1 = m.1 ∨ desc x.1 m.1},
split, swap,
exact builder m.1,
split, swap,
split,
left, swap, exact ⟨m.1, m.2.1⟩,
simp,
intros φ hφ, apply good_model,
exact hrt, apply h, exact hφ
end

theorem correctness (Γ : list nnf) : is_sat Γ = tt ↔ ∃ (st : Type) (k : S4 st) s, sat k s Γ :=
begin
  cases h : is_sat Γ,
  constructor,
  {intro, contradiction},
  {intro hsat, cases eq : tableau (mk_sseqt Γ),
   rcases hsat with ⟨w, k, s, hsat⟩,
   apply false.elim, apply a, simp, exact hsat,
   {dsimp [is_sat] at h, dsimp at eq, rw eq at h, contradiction}},
  {split, intro, dsimp [is_sat] at h,
   cases eq : tableau (mk_sseqt Γ),
   {dsimp at eq, rw eq at h, contradiction},
   {apply model_existence, swap 3, exact a_1.1,
    have := a_1.2, simp at this,
    cases a_1.val with tm ptm,
    cases tm with itm ltm sgtm,
    simp, simp at this, rw this,
    have := a_1.2, simp at this,
    cases a_1.val with tm ptm,
    cases tm with itm ltm sgtm,
    have hsub := itm.mhtk, simp, simp at this,
    rw this at hsub, dsimp at hsub, exact hsub},
  {simp}}
end

-- negation of K
def φ : nnf :=
and (box $ or (neg 1) (var 2)) (and (box $ var 1) (dia $ neg 2))

#eval is_sat [φ] -- ff

-- negation of S4
def ψ : nnf := and (box (var 1)) (dia (dia (neg 1)))

#eval is_sat [ψ] -- ff

def γ : nnf := and (and (dia (var 1)) (dia (var 2))) (box (or (neg 1) (neg 2)))

#eval is_sat [γ] -- tt


import ..scheduling
import ..fairness
import ..spec

import util.predicate

universe variables u u₀ u₁ u₂ u₃
open predicate nat

local infix ` ≃ `:75 := v_eq

namespace temporal

namespace many_to_many
section
open fairness
parameters {α : Type u} {β : Type u₀} {γ : Type u₁ }
parameters {m₀ : mch (γ×α)} {m₁ : mch (γ×β)}
local notation `p` := m₀.init
local notation `q` := m₁.init
local notation `aevt` := m₀.evt
local notation `cevt` := m₁.evt
local notation `cs₀` := m₀.cs
local notation `fs₀` := m₀.fs
local notation `cs₁` := m₁.cs
local notation `fs₁` := m₁.fs
local notation `A` := m₀.A
local notation `C` := m₁.A
local notation `ae`  := m₀.event
local notation `ce`  := m₁.event
local notation `ce'` := m₁.event' (option aevt)
-- local notation `Next₀` := m₀.effect
-- local notation `Next₁` := m₁.effect

parameters (J : pred' (γ×α×β))
parameter ref : option aevt → option cevt → Prop
parameter wit : Π a : aevt, subtype (λ c : cevt, ref a c) → cpred

open prod

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

-- #check (_ × _) × _
-- abbreviation ae' (i : aevt) : event (γ×α×aevt) :=
-- { p := cs₀ i!⟨prod.map_right fst⟩
-- , q := fs₀ i!⟨prod.map_right fst⟩
-- , A := λ s s', s.2.2 = i ∧ (A i on prod.map_right fst) s s' }
-- abbreviation ce' (i : cevt) (j : aevt) : event (γ×β×(cevt×aevt)) :=
-- { p := cs₁ i!⟨prod.map_right fst⟩
-- , q := fs₁ i!⟨prod.map_right fst⟩
-- , A := λ ⟨o,v,ce,_⟩ ⟨o',v',_,ae'⟩, ae' = j ∧ ce = i ∧ C i (o,v) (o',v') }

section specs

-- parameters p q cs₀ fs₀ cs₁ fs₁

def SPEC₀.saf' (v : tvar α) (o : tvar γ) (sch : tvar (option aevt)) : cpred :=
m₀.spec_saf_sch ⦃o,v⦄ (⊙sch)

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

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

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

end specs

parameters [inh_cevt : inhabited cevt]
           [inh_aevt : inhabited aevt]

-- parameter Hc2a : ∀ ce : cevt, ∃ ae : aevt, ref ae ce

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

structure refinement :=
  (SIM₀ : ∀ v o, (o,v) ⊨ q → ∃ w, (o,w) ⊨ p ∧ (o,w,v) ⊨ J)
  (SIM : ∀ cev w v o v' o',
    (o,w,v) ⊨ J →
    m₁.effect cev (o,v) (o',v') →
    ∃ aev w', ref aev cev ∧
             m₀.effect aev (o,w) (o',w') ∧
             (o',w',v') ⊨ J )
  (ANIM : ∀ (e : aevt) (sch : tvar (option aevt)) (o v w),
    many_to_many_po'
      (subtype _)
      (SPEC₁ v o ⋀ SPEC₀.saf' w o sch ⋀ ◻(J ! ⦃o,w,v⦄))
      (wit e)
      (λ e', ce e') (ae e)
      ⦃o,v⦄ ⦃o,w⦄)

section obligations

parameters (v : tvar β) (o : tvar γ)
parameters (Γ : cpred)

parameter Href : refinement

parameters β γ
parameters {β γ}

section conc_sch

parameters (sch_c : tvar (option cevt))

variable (sch_a : tvar (option aevt))

section SPEC₂
variable H : Γ ⊢ SPEC₂ v o sch_c

open prod temporal.prod

-- def Next_a : act $ γ × aevt × α :=
-- λ σ σ',
-- ∃ e, σ.2.1 = e ∧
--       map_right snd σ ⊨ cs₀ e ∧
--       map_right snd σ ⊨ fs₀ e ∧
--       (A e on map_right snd) σ σ'

-- def Next_c : act $ γ × cevt × β :=
-- λ σ σ',
-- ∃ e, σ.2.1 = e ∧
--       map_right snd σ ⊨ cs₁ e ∧
--       map_right snd σ ⊨ fs₁ e ∧
--       (C e on map_right snd) σ σ'

section J
def J' : pred' (γ × (aevt × α) × (cevt × β)) :=
J ! ⟨ prod.map_right $ prod.map prod.snd prod.snd ⟩ ⋀
⟨ λ ⟨_, a, c⟩, ref a.1 c.1 ⟩

-- def JJₐ : pred' (γ × aevt × α) :=
-- Jₐ ! ⟨ prod.map_right snd ⟩

def p' : pred' (γ × aevt × α) :=
p ! ⟨prod.map_right prod.snd⟩

def q' : pred' (γ × cevt × β) :=
q ! ⟨prod.map_right prod.snd⟩

end J
variable w : tvar α
open function
include inh_aevt
-- def Wx₀_f : tvar (β → γ → aevt × α → Prop) :=
-- λ v o (w : aevt × _), (o,w.2) ⊨ p ∧ (o,w.2,v) ⊨ J

-- @[simp]
-- def Wx₀ : tvar (option aevt × α → Prop) :=
-- [| v o , λ (w : option aevt × _), (o,w.2) ⊨ p |]

-- def Wf_f : tvar (option cevt → β → γ → γ → option aevt × α → option aevt × α → Prop) :=
-- ⟪ℕ, λ ce v' o o' (w : _ × _) (w' : option aevt × α),
--              (o',w'.2,v') ⊨ J ∧
--              ref w'.1 ce ∧
--              -- (o,w.2) ⊨ cs₀ w'.1 ∧
--              -- (o,w.2) ⊨ fs₀ w'.1 ∧
--              m₀.effect w'.1 (o,w.2) (o',w'.2) ⟫
--              -- A w'.1 (o,w.2) (o',w'.2) ⟫

-- @[simp]
-- def Wf : tvar (option aevt × α → option aevt × α → Prop) :=
-- ⟪ℕ, λ (cev : option cevt) o o' (w w' : option aevt × α),
--              ref w'.1 cev ∧
--              -- (o,w.2) ⊨ cs₀ w'.1 ∧
--              -- (o,w.2) ⊨ fs₀ w'.1 ∧
--              m₀.effect w'.1 (o,w.2) (o',w'.2) ⟫
--  sch_c o (⊙o)

-- lemma Wx₀_def' (σ : ℕ)
-- : σ ⊨ Wx₀ =
--   ε w : _ × α, (σ ⊨ o,w.2) ⊨ p ∧ (σ ⊨ o,w.2,σ ⊨ v) ⊨ J :=
-- by repeat { unfold_coes <|> simp [Wx₀,Wx₀_f] }

-- @[simp,predicate]
-- lemma Wx₀_def (σ : ℕ) (a b)
-- : (a,b) = σ ⊨ Wx₀ ↔
--   a = (ε w : _ × α,    (σ ⊨ o,w.2) ⊨ p ∧ (σ ⊨ o,w.2,σ ⊨ v) ⊨ J).fst ∧
--   b = (ε w : aevt × α, (σ ⊨ o,w.2) ⊨ p ∧ (σ ⊨ o,w.2,σ ⊨ v) ⊨ J).snd :=
-- by repeat { unfold_coes <|> simp [Wx₀,Wx₀_f,ext] }

-- lemma Wf_def' (σ : ℕ) (w)
-- : σ ⊨ Wf ⦃sch_a,w⦄ =
--   ε w' : _ × α,
--          (succ σ ⊨ o,w'.2,succ σ ⊨ v) ⊨ J ∧
--                ref w'.1 (σ ⊨ sch_c) ∧
--                (σ ⊨ o,σ ⊨ w) ⊨ cs₀ w'.1 ∧
--                (σ ⊨ o,σ ⊨ w) ⊨ fs₀ w'.1 ∧
--                A w'.1 (σ ⊨ o,σ ⊨ w) (succ σ ⊨ o,w'.2) :=
-- by repeat { unfold_coes <|> simp [Wf,Wf_f] }

-- @[simp,predicate]
-- lemma Wf_def (σ : ℕ) (sch_a w) (a b)
-- : (a,b) = (σ ⊨ Wf) (sch_a,w) ↔
--   a = (ε w' : _ × α,
--          (succ σ ⊨ o,w'.2,succ σ ⊨ v) ⊨ J ∧
--                ref w'.1 (σ ⊨ sch_c) ∧
--                (σ ⊨ o,w) ⊨ cs₀ w'.1 ∧
--                (σ ⊨ o,w) ⊨ fs₀ w'.1 ∧
--                A w'.1 (σ ⊨ o,w) (succ σ ⊨ o,w'.2)).1 ∧
--   b = (ε w' : aevt × α,
--          (succ σ ⊨ o,w'.2,succ σ ⊨ v) ⊨ J ∧
--                ref w'.1 (σ ⊨ sch_c) ∧
--                (σ ⊨ o,w) ⊨ cs₀ w'.1 ∧
--                (σ ⊨ o,w) ⊨ fs₀ w'.1 ∧
--                A w'.1 (σ ⊨ o,w) (succ σ ⊨ o,w'.2)).2 :=
-- by repeat { unfold_coes <|> simp [Wf,Wf_f,ext] }

-- variable valid_witness
-- : Γ ⊢ Wtn ⦃sch_a,w⦄

-- lemma abstract_sch (e : aevt)
-- : Γ ⊢ sch_a ≃ e ⋀ cs₀ e ! ⦃o,w⦄ ⋀ fs₀ e ! ⦃o,w⦄ ⋀ ⟦ o,w | A e ⟧ ≡
--       sch_a ≃ e ⋀ ⟦ o,sch_a,w | Next_a ⟧ :=
-- begin
--   lifted_pred [Next_a,on_fun],
--   split ; intro h ; split
--   ; casesm* _ ∧ _ ; subst e ; tauto,
-- end

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

-- omit SIM₀
-- include SIM
-- lemma SIM' (w : aevt × α) (v : cevt × β) (o : γ) (v' : cevt × β) (o' : γ)
--   (h₀ : (o, w, v) ⊨ J')
--   (h₁ : Next_c (o, v) (o', v'))
-- : (∃ w', Next_a (o,w) (o',w') ∧ (o', w', v') ⊨ J') :=
-- begin
--   simp [J',map] at h₀,
--   simp [Next_c,on_fun] at h₁,
--   cases h₀,
--   specialize SIM w.2 v.2 o v'.2 o' v.1 w.1 h₀_right h₀_left h₁,
--   cases SIM with w' SIM,
--   cases Hc2a v'.1 with ae',
--   existsi [(ae',w')],
--   simp [Next_a, J',on_fun,map,h₀_right],
--   tauto,
-- end

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

-- omit H
abbreviation ref' : tvar (option aevt → option cevt → Prop) :=
ref

@[simp]
def Next₀ : act (γ × α × option aevt) :=
λ ⟨o,w,sch_a⟩ ⟨o',w',_⟩, ∃ e, sch_a = e ∧ m₀.effect e (o,w) (o',w')

-- include valid_witness -- init_Jₐ evt_Jₐ
include H Href
-- set_option pp.implicit true

lemma J_inv_in_w'
: Γ ⊢ ∃∃ w, ◻(J ! ⦃o,w,v⦄) ⋀ SPEC₀.saf' w o sch_a :=
begin [temporal]
  -- select_witness w : temporal.many_to_many.Wtn w
  --   with Hw using J ! ⦃o,w.snd,v⦄,
  unfold SPEC₂ mch.spec_sch at H, casesm* _ ⋀ _,

  select_witness w : m₀.init ! ⦃o,w⦄ ⋀ ◻ ⟦ o,w,sch_a | temporal.many_to_many.Next₀ ⟧
    -- with h₀ h₁
    using (J ! ⦃o,w,v⦄)
  { ext, admit, -- simp_coe [to_fun_var'],
    -- simp only with lifted_fn,
    -- congr, funext, transitivity, apply to_fun_var'_lift₂,
    -- -- congr,
    -- simp [to_fun_var'_coe] with lifted_fn,
    -- congr, rw to_fun_var'_id,
    -- refl,
    },
  explicit' with a
  { apply Href.SIM₀, assumption },
  -- simp [SPEC₂] at H,
  -- rw henceforth_next_intro,
  -- dsimp [SPEC₀.saf'],
  -- -- cases valid_witness with h₀ h₀,
  -- casesm* _ ⋀ _,
  -- intros,
  -- t_induction,
  -- { -- select Hw : _ ≃ temporal.many_to_many.Wx₀,
  --   select Hq : q ! _,
  --   have SIM₀ := Href.SIM₀,
  --   explicit' with SIM₀ Hq
  --   { {  },
  --     simp, tauto, } },
  { select H₀ : p_exists _,
    -- henceforth! at h₀_1 H₀ ⊢,
    explicit' [Next₀] with H₀
    { intros h hJ,
      -- casesm* [_ ∧ _,Exists _],
      -- type_check cs₀,
      -- have : (o', h', v') ⊨ J ∧
      --        (o,w) ⊨ cs₀ sch_a' ∧ (o,w) ⊨ fs₀ sch_a' ∧
      --        A sch_a' (o, w) (o', w'),
      -- { subst H₀_w, subst w', subst sch_a',
      --   apply_epsilon_spec,
      --   simp,
      --   apply SIM ; solve_by_elim },
      -- split, tauto,
      -- casesm* _ ∧ _,
      -- apply evt_Jₐ ; apply hJₐ <|> solve_by_elim
      } },
end

-- lemma J_inv_in_w
-- : Γ ⊢ ◻(J ! ⦃o,w,v⦄) :=
-- begin [temporal]
--   cases temporal.many_to_many.J_inv_in_w' _ H _ valid_witness,
--   assumption
-- end

-- lemma abs_J_inv_in_w
-- : Γ ⊢ ◻(Jₐ ! ⦃o,w⦄) :=
-- begin [temporal]
--   cases temporal.many_to_many.J_inv_in_w' _ H _ valid_witness,
--   assumption
-- end

lemma witness_imp_SPEC₀_saf
: Γ ⊢ SPEC₀.saf' w o sch_a :=
begin [temporal]
  simp [SPEC₀.saf',Wtn] at ⊢ valid_witness,
  cases valid_witness with H₀ H₁,
  split,
  explicit' with H₀
  { tauto, },
  henceforth!,
  explicit' with H₁
  { tauto, },
end

omit H
parameters m₀ m₁
include Href
omit valid_witness

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

section
omit Href
include valid_witness Γ H
-- #check w
-- noncomputable def sch_w : tvar aevt :=
-- ⟪ ℕ, λ (w w' : α), ε ae, A ae w w' ⟫ w (⊙w)

-- lemma sch_w_spec
-- : Γ ⊢ ◻(ref' (⊙sch_a) sch_c) :=
-- begin [temporal]
--   have hJ  := temporal.many_to_many.J_inv_in_w _ H _ valid_witness,
--   have hJₐ := temporal.many_to_many.abs_J_inv_in_w _ H _ valid_witness,
--   simp [Wtn,SPEC₂] at valid_witness H,
--   cases valid_witness with Hw' Hw,
--   cases H with H H₀,
--   cases H with H₁ H₂,
--   henceforth! at Hw ⊢ hJ hJₐ H₂,
--   explicit' with Hw hJ hJₐ H₂
--   { cases Hw, subst sch_a', casesm* [_∧_,Exists _],
--     subst sch_c, apply_epsilon_spec,
--     simp, solve_by_elim, },
-- end

end

include H valid_witness

lemma H_C_imp_A (e : option cevt) (e' : option aevt)
  (Hsim : ref e' e)
: Γ ⊢ ◻(sch_c ≃ ↑e ⟶ ⊙sch_a ≃ ↑e' ⟶
        ⟦ o,v | Next₁ e ⟧ ⟶
        ⟦ o,w | Next₀ e' ⟧) :=
begin [temporal]
  have hJ := temporal.many_to_many.J_inv_in_w sch_a H w valid_witness,
  have hJₐ := temporal.many_to_many.abs_J_inv_in_w sch_a H w valid_witness,
  simp [Wtn] at valid_witness,
  cases valid_witness with h₀ h₁,
  cases H with H H₀,
  cases H with H₁ H₂,
  clear_except hJ hJₐ SIM h₁ H₂,
  henceforth! at *,
  explicit' with hJ hJₐ SIM h₁ H₂
  { intros, cases h₁, subst w', subst sch_c,
    subst sch_a', substs e',
    casesm* [_ ∧ _, Exists _], subst e,
    apply_epsilon_spec,
    simp, apply SIM ; solve_by_elim, },
end

omit valid_witness H

lemma Hpo' (e : aevt)
: many_to_many_po'
     _ (SPEC₂ v o sch_c ⋀ Wtn ⦃sch_a,w⦄ ⋀ ◻(J ! ⦃o,w,v⦄))
     (wit e)
     (λ i, ce' i e) (ae e)
     ⦃⦃o,v⦄,sch_c,sch_a⦄ ⦃o,w⦄
:=
begin
  have
  : temporal.many_to_many.SPEC₂ v o sch_c ⋀ temporal.many_to_many.Wtn ⦃sch_a,w⦄ ⋀
      ◻(J ! ⦃o,w,v⦄) ⟹
    temporal.many_to_many.SPEC₁ v o ⋀ temporal.many_to_many.SPEC₀.saf' w o sch_a ⋀
      ◻(J ! ⦃o,w,v⦄),
  begin [temporal]
    simp, intros h₀ h₁ h₂, split*,
    { apply temporal.many_to_many.SPEC₂_imp_SPEC₁ _ _ ; try { solve_by_elim }, },
    { apply temporal.many_to_many.witness_imp_SPEC₀_saf _ h₀ _ h₁, },
    { solve_by_elim }
  end,
  constructor,
  iterate 3
  { cases (Href.ANIM e sch_a o v w),
    simp! [ce',mch.event'] at *,
    transitivity,
    { apply this },
    { assumption } },
  clear this,
  begin [temporal]
    intros,
    casesm* _ ⋀ _,
    select Hw : temporal.many_to_many.Wtn _,
    select hJ : ◻(J ! _),
    select H  : temporal.many_to_many.SPEC₂ _ _ _,
    have := temporal.many_to_many.H_C_imp_A _ H w Hw _ e x.2,
    cases H with H H₀,
    cases H with H₁ H₂,
    clear_except this Href SIM₀ SIM Hw hJ H₂,
    simp [Wtn] at Hw, cases Hw with Hw' Hw,
    henceforth! at ⊢ Hw hJ H₂ this,
    explicit' [mch.event'] with this Hw hJ H₂
    { dsimp [ce',mch.event'], cases Hw,
      intros,
      casesm* [_ ∧ _, Exists _, sch_c = _],
      specialize this _ _ _ ; try { assumption },
      simp [and_assoc,*], exact this, },
  end
end

end Simulation_POs

include H Href

lemma sched_ref (i : aevt) -- (w : tvar (aevt × α))
 (hJ : Γ ⊢ ◻(J ! ⦃o,w,v⦄))
 (Hw : Γ ⊢ Wtn ⦃sch_a,w⦄)
 (h : Γ ⊢ ∀∀ j : cevt, ref ↑i ↑j ⟶ sched (cs₁ j ! ⦃o,v⦄) (fs₁ j ! ⦃o,v⦄) (sch_c ≃ some j ⋀ ⟦ o,v | C j ⟧))
: Γ ⊢ sched (cs₀ i ! ⦃o,w⦄) (fs₀ i ! ⦃o,w⦄) ⟦ o,w | A i ⟧ :=
begin [temporal]
  -- have hJ : ◻(J ! ⦃o,w,v⦄),
  -- { apply temporal.many_to_many.J_inv_in_w ; solve_by_elim },
  apply splitting (Href.ANIM i sch_a o v w) _ _,
  { split*,
    apply temporal.many_to_many.SPEC₂_imp_SPEC₁ _ ; assumption,
    apply temporal.many_to_many.witness_imp_SPEC₀_saf ; assumption,
    assumption },
  intro cev, cases cev with cev Hce,
  simp only, intros H₀ H₁,
  replace h := h cev Hce H₀ H₁,
  revert h,
  monotonicity!,
  explicit'
  { intros, tauto },
end

/-
  This proof works as:
  Init₂ ⇒ Init₀
  Saf₂  ⇒ Saf₀
  Spec₂ ⇒ Live₀
 -/
lemma many_to_many
: Γ ⊢ ∃∃ w, SPEC₀ w o :=
begin [temporal]
  apply p_exists_partial_intro _ (proj $ @pair.snd (option aevt) α) _ _,
  -- replace H := H.left,
  cases H.left with H₀ H₁,
  select_witness w : temporal.many_to_many.Wtn w
    with Hw using J ! ⦃o,w.snd,v⦄,
  explicit' [Wx₀] with H₀
  { apply Href.SIM₀ _ _ H₀, },
  explicit' [Wf] with H₁
  { simp_intros b hJ [and_assoc],
    have := Href.SIM _ _ _ _ _ _ hJ H₁,
    tauto, }, -- a ∧ a ↔ a
  existsi w,
  { apply m₀.spec_of_spec_saf_sch _ (⊙w.fst),
    apply temporal.many_to_many.witness_imp_SPEC₀_saf _ H,
    revert Hw, simp,
    intro, apply temporal.many_to_many.sched_ref w.fst H w.snd x,
    assumption, simp *, introv H',
    apply H.right, },
end
end SPEC₂
end conc_sch

section refinement_SPEC₂
include Href wit inh_aevt
parameters m₀ m₁

lemma refinement_SPEC₂
: Γ ⊢ (∃∃ sch_c, SPEC₂ v o sch_c) ⟶ (∃∃ a, SPEC₀ a o) :=
begin [temporal]
  simp, intros sch Hc,
  apply temporal.many_to_many.many_to_many ;
  solve_by_elim,
end

end refinement_SPEC₂

open nat function set scheduling
include inh_cevt

variables [encodable cevt]

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

end obligations
open function
include J wit inh_cevt inh_aevt

lemma refinement' {o : tvar γ} [encodable cevt]
  (h : refinement)
: (∃∃ c, SPEC₁ c o) ⟹ (∃∃ a, SPEC₀ a o) :=
begin [temporal]
  transitivity (∃∃ c (sch : tvar (option cevt)), SPEC₂ c o sch),
  { apply p_exists_p_imp_p_exists ,
    intro v,
    apply temporal.many_to_many.refinement_SPEC₁, },
  { simp, intros c sch Hspec,
    apply temporal.many_to_many.refinement_SPEC₂ c o Γ h,
    existsi sch, exact Hspec, },
end

end
end many_to_many

end temporal


namespace Monads
  /- Functors capture the notion of a regular computation being executed
     on values that are within another type.
     This type usually captures either the notion of a container, such
     as a list, or a context for a computation, such as receiving data
     from IO.-/
  class Functor (f : Type u → Type v) : Type (max (u+1) v) where
    fmap : (α → β) → f α → f β
    map_const : α → f β → f α := fmap ∘ (Function.const β)

  export Functor (fmap map_const)
  infixr:100 " <$> " => Monads.Functor.fmap
  infixr:90 " <$ " => Monads.Functor.map_const

  namespace Functor
    def const_map {α β : Type u} {f : Type u → Type v} [Functor f] : f β → α → f α := flip map_const
    infixr:90 " $> " => Monads.Functor.const_map
    def void {α : Type} {f : Type → Type} [Functor f] : f α → f Unit := map_const ()
  end Functor

  /- LawfulFunctor ensures the Functor is in fact only applying the function
    to the values and not performing additional computation or modification
    See Maybe.lean for an example why we need both laws to hold for a sensible
    functor. -/
  class LawfulFunctor (f : Type u → Type v) [Functor f] : Prop where
    /- If the function maps values to themselves the values in the functor
       shall remain unchanged -/
    fmap_id : ∀ (x : f α), id <$> x = x
    /- Applying two functions via fmap is the same as applying one composed function
       at once via fmap -/
    fmap_comp : ∀ (g : α → β) (h : β → γ) (x : f α), (h ∘ g) <$> x = h <$> g <$> x
    /- If there is a custom map_const implementation it has to behave like the
       default one. -/
    map_const_behaved: ∀ (x : α) (y : f β), x <$ y = (fmap ∘ (Function.const β)) x y

  namespace LawfulFunctor
    variable {f : Type u → Type v} [Functor f] [LawfulFunctor f]

    example {g : α → β} {x : f α} : g <$> (id <$> x) = g <$> x := by
      rw [fmap_id]

    example {g : α → β} {x : f α} : id <$> (g <$> x) = g <$> x := by
      rw [fmap_id]
  end LawfulFunctor
end Monads


example (n : ℕ) : ℕ := ‹ℕ›


-- lemmas about evaluation

import .definitions3

-- lemmas

lemma binop.eq_of_equal_values {v: value}: binop.apply binop.eq v v = value.true :=
  have binop.apply binop.eq v v = (if v = v then value.true else value.false), by unfold binop.apply,
  show binop.apply binop.eq v v = value.true, by simp[this]

lemma unop.isFunc.inv {v: value}: unop.apply unop.isFunc v = value.true →
      ∃ (f x: var) (R S: spec) (e: exp) (σ: env), v = value.func f x R S e σ :=
  assume isFunc_is_true: unop.apply unop.isFunc v = value.true,
  begin
    cases v with n f x R S e σ,

    show ∃ (f x: var) (R S: spec) (e: exp) (σ: env), value.true = value.func f x R S e σ, from (
      have h1: (unop.apply unop.isFunc value.true = value.true), from isFunc_is_true,
      have h2: (unop.apply unop.isFunc value.true = value.false), by unfold unop.apply,
      have some value.true = some value.false, from eq.trans h1.symm h2,
      have value.true = value.false, from option.some.inj this,
      false.elim (value._mut_.no_confusion this)
    ),

    show ∃ (f x: var) (R S: spec) (e: exp) (σ: env), value.false = value.func f x R S e σ, from (
      have h1: (unop.apply unop.isFunc value.false = value.true), from isFunc_is_true,
      have h2: (unop.apply unop.isFunc value.false = value.false), by unfold unop.apply,
      have some value.true = some value.false, from eq.trans h1.symm h2,
      have value.true = value.false, from option.some.inj this,
      false.elim (value._mut_.no_confusion this)
    ),

    show ∃ (f x: var) (R S: spec) (e: exp) (σ: env), value.num n = value.func f x R S e σ, from (
      have h1: (unop.apply unop.isFunc (value.num n) = value.true), from isFunc_is_true,
      have h2: (unop.apply unop.isFunc (value.num n) = value.false), by unfold unop.apply,
      have some value.true = some value.false, from eq.trans h1.symm h2,
      have value.true = value.false, from option.some.inj this,
      false.elim (value._mut_.no_confusion this)
    ),

    show ∃ (f_1 x_1: var) (R_1 S_1: spec) (e_1: exp) (σ_1: env),
        value.func f x R S e σ = value.func f_1 x_1 R_1 S_1 e_1 σ_1, from (
      exists.intro f (exists.intro x (exists.intro R (exists.intro S
                     (exists.intro e (exists.intro σ rfl)))))
    )
  end

lemma unop.isBool.inv {v: value}: unop.apply unop.isBool v = value.true → (v = value.true) ∨ (v = value.false) :=
  assume isBool_is_true: unop.apply unop.isBool v = value.true,
  begin
    cases v with n f x R S e σ,

    show ((value.true = value.true) ∨ (value.true = value.false)), from (
      or.inl rfl
    ),

    show ((value.false = value.true) ∨ (value.false = value.false)), from (
      or.inr rfl
    ),

    show (value.num n = value.true ∨ (value.num n = value.false)), from (
      have h1: unop.apply unop.isBool (value.num n) = ↑value.true, from isBool_is_true,
      have h2: (unop.apply unop.isBool (value.num n) = value.false), by unfold unop.apply,
      have some value.true = some value.false, from eq.trans h1.symm h2,
      have value.true = value.false, from option.some.inj this,
      false.elim (value._mut_.no_confusion this)
    ),

    show (value.func f x R S e σ = value.true ∨ (value.func f x R S e σ = value.false)), from (
      have h1: unop.apply unop.isBool (value.func f x R S e σ) = ↑value.true, from isBool_is_true,
      have h2: (unop.apply unop.isBool (value.func f x R S e σ) = value.false), by unfold unop.apply,
      have some value.true = some value.false, from eq.trans h1.symm h2,
      have value.true = value.false, from option.some.inj this,
      false.elim (value._mut_.no_confusion this)
    )
  end

lemma binop.eq.inv {v₁ v₂: value}: binop.apply binop.eq v₁ v₂ = value.true → (v₁ = v₂) :=
  assume eq_is_true: binop.apply binop.eq v₁ v₂ = value.true,
  begin
    by_cases (v₁ = v₂),
    from h,
    unfold binop.apply at eq_is_true,
    simp[h] at eq_is_true,
    have h2, from option.some.inj eq_is_true,
    contradiction
  end

lemma pre_preserved {s s': dstack}: s ⟹* s' → (s.pre = s'.pre) :=
  begin
    assume h1,
    induction h1,
    case trans_dstep.rfl {
      refl
    },
    case trans_dstep.trans s₁ s₂ s₃ h2 h3 ih {
      apply eq.trans ih,
      cases h3,
      repeat {refl}
    }
  end

lemma unop_result_not_function {vx vy: value} {op: unop}:
      (unop.apply op vx = some vy) → (vy = value.true) ∨ (vy = value.false) :=
  begin
    assume h1,
    cases op,
    case unop.not {
      cases vx,

      unfold unop.apply at h1,
      have h2: (value.false = vy), from option.some.inj h1,
      right,
      from h2.symm,

      unfold unop.apply at h1,
      have h2: (value.true = vy), from option.some.inj h1,
      left,
      from h2.symm,

      unfold unop.apply at h1,
      contradiction,

      unfold unop.apply at h1,
      contradiction
    },
    case unop.isInt {
      cases vx,

      unfold unop.apply at h1,
      have h2: (value.false = vy), from option.some.inj h1,
      right,
      from h2.symm,

      unfold unop.apply at h1,
      have h2: (value.false = vy), from option.some.inj h1,
      right,
      from h2.symm,

      unfold unop.apply at h1,
      have h2: (value.true = vy), from option.some.inj h1,
      left,
      from h2.symm,

      unfold unop.apply at h1,
      have h2: (value.false = vy), from option.some.inj h1,
      right,
      from h2.symm
    },
    case unop.isBool {
      cases vx,

      unfold unop.apply at h1,
      have h2: (value.true = vy), from option.some.inj h1,
      left,
      from h2.symm,

      unfold unop.apply at h1,
      have h2: (value.true = vy), from option.some.inj h1,
      left,
      from h2.symm,

      unfold unop.apply at h1,
      have h2: (value.false = vy), from option.some.inj h1,
      right,
      from h2.symm,

      unfold unop.apply at h1,
      have h2: (value.false = vy), from option.some.inj h1,
      right,
      from h2.symm
    },
    case unop.isFunc {
      cases vx,

      unfold unop.apply at h1,
      have h2: (value.false = vy), from option.some.inj h1,
      right,
      from h2.symm,

      unfold unop.apply at h1,
      have h2: (value.false = vy), from option.some.inj h1,
      right,
      from h2.symm,

      unfold unop.apply at h1,
      have h2: (value.false = vy), from option.some.inj h1,
      right,
      from h2.symm,

      unfold unop.apply at h1,
      have h2: (value.true = vy), from option.some.inj h1,
      left,
      from h2.symm
    }
  end

lemma binop_result_not_function {vx vy vz: value} {op: binop}:
      (binop.apply op vx vy = some vz) → ((vz = value.true) ∨ (vz = value.false) ∨ (∃n, vz = value.num n)) :=
  begin
    assume h1,
    cases op,
    case binop.plus {
      cases vx,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      cases vy,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      have h2: (value.num (a + a_1) = vz), from option.some.inj h1,
      right,
      right,
      existsi (a + a_1),
      from h2.symm,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction
    },
    case binop.minus {
      cases vx,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      cases vy,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      have h2: (value.num (a - a_1) = vz), from option.some.inj h1,
      right,
      right,
      existsi (a - a_1),
      from h2.symm,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction
    },
    case binop.times {
      cases vx,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      cases vy,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      have h2: (value.num (a * a_1) = vz), from option.some.inj h1,
      right,
      right,
      existsi (a * a_1),
      from h2.symm,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction
    },
    case binop.div {
      cases vx,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      cases vy,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      have h2: (value.num (a / a_1) = vz), from option.some.inj h1,
      right,
      right,
      existsi (a / a_1),
      from h2.symm,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction
    },
    case binop.and {
      cases vx,
      cases vy,

      unfold binop.apply at h1,
      have h2: (value.true = vz), from option.some.inj h1,
      left,
      from h2.symm,

      unfold binop.apply at h1,
      have h2: (value.false = vz), from option.some.inj h1,
      right,
      left,
      from h2.symm,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      cases vy,

      unfold binop.apply at h1,
      have h2: (value.false = vz), from option.some.inj h1,
      right,
      left,
      from h2.symm,

      unfold binop.apply at h1,
      have h2: (value.false = vz), from option.some.inj h1,
      right,
      left,
      from h2.symm,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction
    },
    case binop.or {
      cases vx,
      cases vy,

      unfold binop.apply at h1,
      have h2: (value.true = vz), from option.some.inj h1,
      left,
      from h2.symm,

      unfold binop.apply at h1,
      have h2: (value.true = vz), from option.some.inj h1,
      left,
      from h2.symm,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      cases vy,

      unfold binop.apply at h1,
      have h2: (value.true = vz), from option.some.inj h1,
      left,
      from h2.symm,

      unfold binop.apply at h1,
      have h2: (value.false = vz), from option.some.inj h1,
      right,
      left,
      from h2.symm,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction
    },
    case binop.eq {
      unfold binop.apply at h1,
      by_cases (vx = vy),
      simp[h] at h1,

      have h2: (value.true = vz), from option.some.inj h1,
      left,
      from h2.symm,

      simp[h] at h1,
      have h2: (value.false = vz), from option.some.inj h1,
      right,
      left,
      from h2.symm
    },
    case binop.lt {
      cases vx,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      cases vy,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      by_cases (a < a_1),

      simp[h] at h1,
      have h2: (value.true = vz), from option.some.inj h1,
      left,
      from h2.symm,

      simp[h] at h1,
      have h2: (value.false = vz), from option.some.inj h1,
      right,
      left,
      from h2.symm,

      unfold binop.apply at h1,
      contradiction,

      unfold binop.apply at h1,
      contradiction    }
  end

lemma step_dstep_progress {s s': stack}:
      (s ⟶ s') → ∀d, stack_equiv_dstack s d → ∃d', (d ⟹ d') :=
  begin
    assume h1,

    induction h1,

    case step.tru {
      assume d,
      assume h2,
      cases h2,

      existsi (dstack.top R (σ[x↦value.true]) e),
      apply dstep.tru
    },

    case step.fals {
      assume d,
      assume h2,
      cases h2,

      existsi (dstack.top R (σ[x↦value.false]) e),
      apply dstep.fals
    },

    case step.num {
      assume d,
      assume h2,
      cases h2,

      existsi (dstack.top R (σ[x↦value.num n]) e),
      apply dstep.num
    },

    case step.closure {
      assume d,
      assume h2,
      cases h2,

      existsi (dstack.top R_1 (σ[f↦value.func f x R S e₁ σ]) e₂),
      apply dstep.closure
    },

    case step.unop {
      assume d,
      assume h2,
      cases h2,

      existsi (dstack.top R (σ[y↦v]) e),
      apply dstep.unop a a_1
    },

    case step.binop {
      assume d,
      assume h2,
      cases h2,

      existsi (dstack.top R (σ[z↦v]) e),
      apply dstep.binop a a_1 a_2
    },

    case step.app {
      assume d,
      assume h2,
      cases h2,

      existsi (dstack.cons (R, (σ'[g↦value.func g z R S e σ'][z↦v]), e) R_1 σ y f x e'),
      apply dstep.app a a_1
    },

    case step.ite_true {
      assume d,
      assume h2,
      cases h2,

      existsi (dstack.top R σ e₁),
      apply dstep.ite_true a
    },

    case step.ite_false {
      assume d,
      assume h2,
      cases h2,

      existsi (dstack.top R σ e₂),
      apply dstep.ite_false a
    },

    case step.ctx s₁ s₂ σ₁ f x y e₁ steps ih {
      assume d,
      assume h2,
      cases h2,

      have h3, from ih d' a,
      cases h3 with d'' h4,

      existsi (dstack.cons d'' R σ₁ y f x e₁),
      apply dstep.ctx h4
    },

    case step.return {
      assume d,
      assume h2,
      cases h2,

      existsi (dstack.top R_1 (σ₂[y↦v]) e'),
      cases a_3,
      apply dstep.return a a_1 a_2
    }
  end

lemma step_dstep_progress.inv {d d': dstack}:
      (d ⟹ d') → ∀s, stack_equiv_dstack s d → ∃s', (s ⟶ s') :=
  begin
    assume h1,

    induction h1,

    case dstep.tru {
      assume s,
      assume h2,
      cases h2,

      existsi (stack.top (σ[x↦value.true]) e),
      apply step.tru
    },

    case dstep.fals {
      assume s,
      assume h2,
      cases h2,

      existsi (stack.top (σ[x↦value.false]) e),
      apply step.fals
    },

    case dstep.num {
      assume s,
      assume h2,
      cases h2,

      existsi (stack.top (σ[x↦value.num n]) e),
      apply step.num
    },

    case dstep.closure {
      assume s,
      assume h2,
      cases h2,

      existsi (stack.top (σ[f↦value.func f x R S e₁ σ]) e₂),
      apply step.closure,
      from spec.term value.true
    },

    case dstep.unop {
      assume s,
      assume h2,
      cases h2,

      existsi (stack.top (σ[y↦v]) e),
      apply step.unop a a_1
    },

    case dstep.binop {
      assume s,
      assume h2,
      cases h2,

      existsi (stack.top (σ[z↦v]) e),
      apply step.binop a a_1 a_2
    },

    case dstep.app {
      assume s,
      assume h2,
      cases h2,

      existsi (stack.cons ((σ'[g↦value.func g z R S e σ'][z↦v]), e) σ y f x e'),
      apply step.app a a_1
    },

    case dstep.ite_true {
      assume s,
      assume h2,
      cases h2,

      existsi (stack.top σ e₁),
      apply step.ite_true a
    },

    case dstep.ite_false {
      assume s,
      assume h2,
      cases h2,

      existsi (stack.top σ e₂),
      apply step.ite_false a
    },

    case dstep.ctx d₁ d₂ R σ₁ f x y e₁ steps ih {
      assume s,
      assume h2,
      cases h2,

      have h3, from ih s' a,
      cases h3 with s'' h4,

      existsi (stack.cons s'' σ₁ y f x e₁),
      apply step.ctx h4
    },

    case dstep.return {
      assume s,
      assume h2,
      cases h2,

      existsi (stack.top (σ₂[y↦v]) e'),
      cases a_3,
      apply step.return a a_1 a_2
    }
  end

lemma step_dstep_preservation {s: stack}:
      ∀{s': stack} {d d': dstack},
      stack_equiv_dstack s d → (s ⟶ s') → (d ⟹ d') → stack_equiv_dstack s' d' :=
  begin
    induction s,

    case stack.top σ e {
      assume s' d d',
      assume h1,
      assume h2,
      assume h3,
      cases h1,
      have h4: (dstack.top R σ e ⟹ d'), from h3,
      cases h2,

      case step.tru {
        cases h4,
        simp,
        apply stack_equiv_dstack.top
      },

      case step.fals {
        cases h4,
        simp,
        apply stack_equiv_dstack.top
      },

      case step.num {
        cases h4,
        simp,
        apply stack_equiv_dstack.top
      },

      case step.closure {
        cases h4,
        simp,
        apply stack_equiv_dstack.top
      },

      case step.unop {
        cases h4,
        simp,
        have h5, from eq.trans a.symm a_2,
        have h6: (v₁ = v₁_1), from option.some.inj h5,
        rw[h6] at a_1,
        have h7, from eq.trans a_1.symm a_3,
        have h8: (v = v_1), from option.some.inj h7,
        rw[h8],
        apply stack_equiv_dstack.top
      },

      case step.binop {
        cases h4,
        simp,
        have h5, from eq.trans a.symm a_3,
        have h6: (v₁ = v₁_1), from option.some.inj h5,
        rw[h6] at a_2,
        have h7, from eq.trans a_1.symm a_4,
        have h8: (v₂ = v₂_1), from option.some.inj h7,
        rw[h8] at a_2,
        have h9, from eq.trans a_2.symm a_5,
        have h10: (v = v_1), from option.some.inj h9,
        rw[h10],

        apply stack_equiv_dstack.top
      },

      case step.app {
        cases h4,
        apply stack_equiv_dstack.cons,
        have h5, from eq.trans a.symm a_2,
        have h6: ((value.func g z R_1 S e_1 σ') = (value.func g_1 z_1 R_2 S_1 e σ'_1)),
        from option.some.inj h5,
        injection h6,
        rw[h_1],
        rw[h_2],
        rw[h_3],
        rw[h_4],
        rw[h_5],
        rw[h_6],
        have h7, from eq.trans a_1.symm a_3,
        have h8: (v = v_1), from option.some.inj h7,
        rw[h8],
        apply stack_equiv_dstack.top
      },

      case step.ite_true {
        cases h4,
        simp,
        apply stack_equiv_dstack.top,
        have h7, from eq.trans a.symm a_1,
        have h8: (value.true = value.false), from option.some.inj h7,
        contradiction
      },

      case step.ite_false {
        cases h4,
        simp,
        have h7, from eq.trans a.symm a_1,
        have h8: (value.false = value.true), from option.some.inj h7,
        contradiction,
        apply stack_equiv_dstack.top,
      },
    },

    case stack.cons s'' σ'' f x y e'' ih {
      assume s' d d',
      assume h1,
      assume h2,
      assume h3,
      cases h1,
      cases h2,

      case step.ctx {
        cases h3,

        apply stack_equiv_dstack.cons,
        from ih a a_1 a_2,

        simp at a,
        cases a,
        cases a_1
      },

      case step.return {
        cases h3,

        simp at a,
        cases a,
        cases a_4,

        simp,
        cases a,
        have h5, from eq.trans a_1.symm a_4,
        have h6: (v = v_1), from option.some.inj h5,
        rw[h6],
        apply stack_equiv_dstack.top,
      }
    }
  end

lemma step_of_dstep_trans {d d': dstack}:
      (d ⟹* d') → ∀s, stack_equiv_dstack s d → ∃s', (s ⟶* s') ∧ stack_equiv_dstack s' d' :=
  begin
    assume h1,

    induction h1,

    assume s,
    assume h2,
    existsi s,
    split,
    from trans_step.rfl,
    from h2,

    assume s_1,
    assume h2,
    have h3, from ih_1 s_1 h2,
    cases h3 with s_2 h4,

    have h5, from step_dstep_progress.inv a_1 s_2 h4.right,
    cases h5 with s3 h6,

    existsi s3,
    split,
    apply trans_step.trans,
    from h4.left,
    from h6,

    apply step_dstep_preservation h4.right h6 a_1
  end

lemma dstep_of_step_trans {s s': stack}:
      (s ⟶* s') → ∀d, stack_equiv_dstack s d → ∃d', (d ⟹* d') ∧ stack_equiv_dstack s' d' :=
  begin
    assume h1,

    induction h1,

    assume d,
    assume h2,
    existsi d,
    split,
    from trans_dstep.rfl,
    from h2,

    assume s_1,
    assume h2,
    have h3, from ih_1 s_1 h2,
    cases h3 with s_2 h4,

    have h5: ∃ (d' : dstack), s_2⟹d', from step_dstep_progress a_1 s_2 h4.right,
    cases h5 with s3 h6,

    existsi s3,
    split,
    apply trans_dstep.trans,
    from h4.left,
    from h6,

    apply step_dstep_preservation h4.right a_1 h6
  end

lemma step_of_dstep {R₁ R₂: spec} {σ₁ σ₂: env} {e₁ e₂: exp}: (R₁, σ₁, e₁) ⟹* (R₂, σ₂, e₂) → ((σ₁, e₁) ⟶* (σ₂, e₂)) :=
  begin
    assume h1,
    have h2: stack_equiv_dstack (σ₁, e₁) (R₁, σ₁, e₁), from stack_equiv_dstack.top,
    have h3, from step_of_dstep_trans h1 (σ₁, e₁) h2,
    cases h3 with s' h4,
    cases h4.right,
    from h4.left
  end

lemma value_or_step_of_dvalue_or_dstep {s: stack} {d: dstack}:
  stack_equiv_dstack s d → (is_dvalue d ∨ ∃d', d ⟹ d') → (is_value s ∨ ∃s', s ⟶ s') :=
  begin
    assume h1,
    assume h2,
    cases h2 with h3 h3,
    unfold is_dvalue at h3,
    cases h3 with R h4,
    cases h4 with σ h5,
    cases h5 with x h6,
    cases h6 with v h7,
    left,
    unfold is_value,
    existsi σ,
    existsi x,
    existsi v,
    split,
    rw[h7.left] at h1,
    cases h1,
    congr,
    from h7.right,
    cases h3 with d' h4,
    have h5, from step_dstep_progress.inv h4 s h1,
    right,
    from h5
  end


import LMT

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

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


import LMT

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

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


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

Type class instance synthesizer using tabled resolution.
-/
import Lean.Meta.Basic
import Lean.Meta.Instances
import Lean.Meta.AbstractMVars
import Lean.Meta.WHNF
import Lean.Meta.Check
import Lean.Util.Profile

namespace Lean.Meta

register_builtin_option synthInstance.maxHeartbeats : Nat := {
  defValue := 20000
  descr := "maximum amount of heartbeats per typeclass resolution problem. A heartbeat is number of (small) memory allocations (in thousands), 0 means no limit"
}

register_builtin_option synthInstance.maxSize : Nat := {
  defValue := 128
  descr := "maximum number of instances used to construct a solution in the type class instance synthesis procedure"
}

register_builtin_option synthInstance.etaExperiment : Bool := {
  defValue := false
  descr := "[DO NOT USE EXCEPT FOR TESTING] enable structure eta for type-classes during type-class search"
}

namespace SynthInstance

def getMaxHeartbeats (opts : Options) : Nat :=
  synthInstance.maxHeartbeats.get opts * 1000

builtin_initialize inferTCGoalsRLAttr : TagAttribute ←
  registerTagAttribute `infer_tc_goals_rl "instruct type class resolution procedure to solve goals from right to left for this instance"

def hasInferTCGoalsRLAttribute (env : Environment) (constName : Name) : Bool :=
  inferTCGoalsRLAttr.hasTag env constName

structure GeneratorNode where
  mvar            : Expr
  key             : Expr
  mctx            : MetavarContext
  instances       : Array Expr
  currInstanceIdx : Nat
  deriving Inhabited

structure ConsumerNode where
  mvar     : Expr
  key      : Expr
  mctx     : MetavarContext
  subgoals : List Expr
  size     : Nat -- instance size so far
  deriving Inhabited

inductive Waiter where
  | consumerNode : ConsumerNode → Waiter
  | root         : Waiter

def Waiter.isRoot : Waiter → Bool
  | Waiter.consumerNode _ => false
  | Waiter.root           => true

/-!
  In tabled resolution, we creating a mapping from goals (e.g., `Coe Nat ?x`) to
  answers and waiters. Waiters are consumer nodes that are waiting for answers for a
  particular node.

  We implement this mapping using a `HashMap` where the keys are
  normalized expressions. That is, we replace assignable metavariables
  with auxiliary free variables of the form `_tc.<idx>`. We do
  not declare these free variables in any local context, and we should
  view them as "normalized names" for metavariables. For example, the
  term `f ?m ?m ?n` is normalized as
  `f _tc.0 _tc.0 _tc.1`.

  This approach is structural, and we may visit the same goal more
  than once if the different occurrences are just definitionally
  equal, but not structurally equal.

  Remark: a metavariable is assignable only if its depth is equal to
  the metavar context depth.
-/
namespace  MkTableKey

structure State where
  nextIdx : Nat := 0
  lmap    : HashMap LMVarId Level := {}
  emap    : HashMap MVarId Expr := {}
  mctx    : MetavarContext

abbrev M := StateM State

@[always_inline]
instance : MonadMCtx M where
  getMCtx := return (← get).mctx
  modifyMCtx f := modify fun s => { s with mctx := f s.mctx }

partial def normLevel (u : Level) : M Level := do
  if !u.hasMVar then
    return u
  else match u with
    | Level.succ v      => return u.updateSucc! (← normLevel v)
    | Level.max v w     => return u.updateMax! (← normLevel v) (← normLevel w)
    | Level.imax v w    => return u.updateIMax! (← normLevel v) (← normLevel w)
    | Level.mvar mvarId =>
      if (← getMCtx).getLevelDepth mvarId != (← getMCtx).depth then
        return u
      else
        let s ← get
        match (← get).lmap.find? mvarId with
        | some u' => pure u'
        | none    =>
          let u' := mkLevelParam <| Name.mkNum `_tc s.nextIdx
          modify fun s => { s with nextIdx := s.nextIdx + 1, lmap := s.lmap.insert mvarId u' }
          return u'
    | u => return u

partial def normExpr (e : Expr) : M Expr := do
  if !e.hasMVar then
    pure e
  else match e with
    | Expr.const _ us      => return e.updateConst! (← us.mapM normLevel)
    | Expr.sort u          => return e.updateSort! (← normLevel u)
    | Expr.app f a         => return e.updateApp! (← normExpr f) (← normExpr a)
    | Expr.letE _ t v b _  => return e.updateLet! (← normExpr t) (← normExpr v) (← normExpr b)
    | Expr.forallE _ d b _ => return e.updateForallE! (← normExpr d) (← normExpr b)
    | Expr.lam _ d b _     => return e.updateLambdaE! (← normExpr d) (← normExpr b)
    | Expr.mdata _ b       => return e.updateMData! (← normExpr b)
    | Expr.proj _ _ b      => return e.updateProj! (← normExpr b)
    | Expr.mvar mvarId     =>
      if !(← mvarId.isAssignable) then
        return e
      else
        let s ← get
        match s.emap.find? mvarId with
        | some e' => pure e'
        | none    => do
          let e' := mkFVar { name := Name.mkNum `_tc s.nextIdx }
          modify fun s => { s with nextIdx := s.nextIdx + 1, emap := s.emap.insert mvarId e' }
          return e'
    | _ => return e

end MkTableKey

/-- Remark: `mkTableKey` assumes `e` does not contain assigned metavariables. -/
def mkTableKey [Monad m] [MonadMCtx m] (e : Expr) : m Expr := do
  let (r, s) := MkTableKey.normExpr e |>.run { mctx := (← getMCtx) }
  setMCtx s.mctx
  return r

structure Answer where
  result     : AbstractMVarsResult
  resultType : Expr
  size       : Nat
  deriving Inhabited

structure TableEntry where
  waiters : Array Waiter
  answers : Array Answer := #[]

structure Context where
  maxResultSize : Nat
  maxHeartbeats : Nat

/--
  Remark: the SynthInstance.State is not really an extension of `Meta.State`.
  The field `postponed` is not needed, and the field `mctx` is misleading since
  `synthInstance` methods operate over different `MetavarContext`s simultaneously.
  That being said, we still use `extends` because it makes it simpler to move from
  `M` to `MetaM`.
-/
structure State where
  result?        : Option AbstractMVarsResult    := none
  generatorStack : Array GeneratorNode           := #[]
  resumeStack    : Array (ConsumerNode × Answer) := #[]
  tableEntries   : HashMap Expr TableEntry       := {}

abbrev SynthM := ReaderT Context $ StateRefT State MetaM

def checkMaxHeartbeats : SynthM Unit := do
  Core.checkMaxHeartbeatsCore "typeclass" `synthInstance.maxHeartbeats (← read).maxHeartbeats

@[inline] def mapMetaM (f : forall {α}, MetaM α → MetaM α) {α} : SynthM α → SynthM α :=
  monadMap @f

instance : Inhabited (SynthM α) where
  default := fun _ _ => default

/-- Return globals and locals instances that may unify with `type` -/
def getInstances (type : Expr) : MetaM (Array Expr) := do
  -- We must retrieve `localInstances` before we use `forallTelescopeReducing` because it will update the set of local instances
  let localInstances ← getLocalInstances
  forallTelescopeReducing type fun _ type => do
    let className? ← isClass? type
    match className? with
    | none   => throwError "type class instance expected{indentExpr type}"
    | some className =>
      let globalInstances ← getGlobalInstancesIndex
      let result ← globalInstances.getUnify type
      -- Using insertion sort because it is stable and the array `result` should be mostly sorted.
      -- Most instances have default priority.
      let result := result.insertionSort fun e₁ e₂ => e₁.priority < e₂.priority
      let erasedInstances ← getErasedInstances
      let result ← result.filterMapM fun e => match e.val with
        | Expr.const constName us =>
          if erasedInstances.contains constName then
            return none
          else
            return some <| e.val.updateConst! (← us.mapM (fun _ => mkFreshLevelMVar))
        | _ => panic! "global instance is not a constant"
      let result := localInstances.foldl (init := result) fun (result : Array Expr) linst =>
        if linst.className == className then result.push linst.fvar else result
      trace[Meta.synthInstance.instances] result
      return result

def mkGeneratorNode? (key mvar : Expr) : MetaM (Option GeneratorNode) := do
  let mvarType  ← inferType mvar
  let mvarType  ← instantiateMVars mvarType
  let instances ← getInstances mvarType
  if instances.isEmpty then
    return none
  else
    let mctx ← getMCtx
    return some {
      mvar, key, mctx, instances
      currInstanceIdx := instances.size
    }

/--
  Create a new generator node for `mvar` and add `waiter` as its waiter.
  `key` must be `mkTableKey mctx mvarType`. -/
def newSubgoal (mctx : MetavarContext) (key : Expr) (mvar : Expr) (waiter : Waiter) : SynthM Unit :=
  withMCtx mctx do withTraceNode' `Meta.synthInstance do
    match (← mkGeneratorNode? key mvar) with
    | none      => pure ((), m!"no instances for {key}")
    | some node =>
      let entry : TableEntry := { waiters := #[waiter] }
      modify fun s =>
       { s with
         generatorStack := s.generatorStack.push node
         tableEntries   := s.tableEntries.insert key entry }
      pure ((), m!"new goal {key}")

def findEntry? (key : Expr) : SynthM (Option TableEntry) := do
  return (← get).tableEntries.find? key

def getEntry (key : Expr) : SynthM TableEntry := do
  match (← findEntry? key) with
  | none       => panic! "invalid key at synthInstance"
  | some entry => pure entry

/--
  Create a `key` for the goal associated with the given metavariable.
  That is, we create a key for the type of the metavariable.

  We must instantiate assigned metavariables before we invoke `mkTableKey`. -/
def mkTableKeyFor (mctx : MetavarContext) (mvar : Expr) : SynthM Expr :=
  withMCtx mctx do
    let mvarType ← inferType mvar
    let mvarType ← instantiateMVars mvarType
    mkTableKey mvarType

/-- See `getSubgoals` and `getSubgoalsAux`

   We use the parameter `j` to reduce the number of `instantiate*` invocations.
   It is the same approach we use at `forallTelescope` and `lambdaTelescope`.
   Given `getSubgoalsAux args j subgoals instVal type`,
   we have that `type.instantiateRevRange j args.size args` does not have loose bound variables. -/
structure SubgoalsResult where
  subgoals     : List Expr
  instVal      : Expr
  instTypeBody : Expr

private partial def getSubgoalsAux (lctx : LocalContext) (localInsts : LocalInstances) (xs : Array Expr)
    : Array Expr → Nat → List Expr → Expr → Expr → MetaM SubgoalsResult
  | args, j, subgoals, instVal, Expr.forallE _ d b bi => do
    let d        := d.instantiateRevRange j args.size args
    let mvarType ← mkForallFVars xs d
    let mvar     ← mkFreshExprMVarAt lctx localInsts mvarType
    let arg      := mkAppN mvar xs
    let instVal  := mkApp instVal arg
    let subgoals := if bi.isInstImplicit then mvar::subgoals else subgoals
    let args     := args.push (mkAppN mvar xs)
    getSubgoalsAux lctx localInsts xs args j subgoals instVal b
  | args, j, subgoals, instVal, type => do
    let type := type.instantiateRevRange j args.size args
    let type ← whnf type
    if type.isForall then
      getSubgoalsAux lctx localInsts xs args args.size subgoals instVal type
    else
      return ⟨subgoals, instVal, type⟩

/--
  `getSubgoals lctx localInsts xs inst` creates the subgoals for the instance `inst`.
  The subgoals are in the context of the free variables `xs`, and
  `(lctx, localInsts)` is the local context and instances before we added the free variables to it.

  This extra complication is required because
    1- We want all metavariables created by `synthInstance` to share the same local context.
    2- We want to ensure that applications such as `mvar xs` are higher order patterns.

  The method `getGoals` create a new metavariable for each parameter of `inst`.
  For example, suppose the type of `inst` is `forall (x_1 : A_1) ... (x_n : A_n), B x_1 ... x_n`.
  Then, we create the metavariables `?m_i : forall xs, A_i`, and return the subset of these
  metavariables that are instance implicit arguments, and the expressions:
    - `inst (?m_1 xs) ... (?m_n xs)` (aka `instVal`)
    - `B (?m_1 xs) ... (?m_n xs)` -/
def getSubgoals (lctx : LocalContext) (localInsts : LocalInstances) (xs : Array Expr) (inst : Expr) : MetaM SubgoalsResult := do
  let instType ← inferType inst
  let result ← getSubgoalsAux lctx localInsts xs #[] 0 [] inst instType
  if let .const constName _ := inst.getAppFn then
    let env ← getEnv
    if hasInferTCGoalsRLAttribute env constName then
      return result
  return { result with subgoals := result.subgoals.reverse }

/--
  Try to synthesize metavariable `mvar` using the instance `inst`.
  Remark: `mctx` is set using `withMCtx`.
  If it succeeds, the result is a new updated metavariable context and a new list of subgoals.
  A subgoal is created for each instance implicit parameter of `inst`. -/
def tryResolve (mvar : Expr) (inst : Expr) : MetaM (Option (MetavarContext × List Expr)) := do
  let mvarType   ← inferType mvar
  let lctx       ← getLCtx
  let localInsts ← getLocalInstances
  forallTelescopeReducing mvarType fun xs mvarTypeBody => do
    let ⟨subgoals, instVal, instTypeBody⟩ ← getSubgoals lctx localInsts xs inst
    withTraceNode `Meta.synthInstance.tryResolve (withMCtx (← getMCtx) do
        return m!"{exceptOptionEmoji ·} {← instantiateMVars mvarTypeBody} ≟ {← instantiateMVars instTypeBody}") do
    if (← isDefEq mvarTypeBody instTypeBody) then
      let instVal ← mkLambdaFVars xs instVal
      if (← isDefEq mvar instVal) then
        return some ((← getMCtx), subgoals)
    return none

/--
  Assign a precomputed answer to `mvar`.
  If it succeeds, the result is a new updated metavariable context and a new list of subgoals. -/
def tryAnswer (mctx : MetavarContext) (mvar : Expr) (answer : Answer) : SynthM (Option MetavarContext) :=
  withMCtx mctx do
    let (_, _, val) ← openAbstractMVarsResult answer.result
    if (← isDefEq mvar val) then
      return some (← getMCtx)
    else
      return none

/-- Move waiters that are waiting for the given answer to the resume stack. -/
def wakeUp (answer : Answer) : Waiter → SynthM Unit
  | Waiter.root               => do
    /- Recall that we now use `ignoreLevelMVarDepth := true`. Thus, we should allow solutions
       containing universe metavariables, and not check `answer.result.paramNames.isEmpty`.
       We use `openAbstractMVarsResult` to construct the universe metavariables
       at the correct depth. -/
    if answer.result.numMVars == 0 then
      modify fun s => { s with result? := answer.result }
    else
      let (_, _, answerExpr) ← openAbstractMVarsResult answer.result
      trace[Meta.synthInstance] "skip answer containing metavariables {answerExpr}"
  | Waiter.consumerNode cNode =>
    modify fun s => { s with resumeStack := s.resumeStack.push (cNode, answer) }

def isNewAnswer (oldAnswers : Array Answer) (answer : Answer) : Bool :=
  oldAnswers.all fun oldAnswer =>
    -- Remark: isDefEq here is too expensive. TODO: if `==` is too imprecise, add some light normalization to `resultType` at `addAnswer`
    -- iseq ← isDefEq oldAnswer.resultType answer.resultType; pure (!iseq)
    oldAnswer.resultType != answer.resultType

private def mkAnswer (cNode : ConsumerNode) : MetaM Answer :=
  withMCtx cNode.mctx do
    let val ← instantiateMVars cNode.mvar
    trace[Meta.synthInstance.newAnswer] "size: {cNode.size}, val: {val}"
    let result ← abstractMVars val -- assignable metavariables become parameters
    let resultType ← inferType result.expr
    return { result, resultType, size := cNode.size + 1 }

/--
  Create a new answer after `cNode` resolved all subgoals.
  That is, `cNode.subgoals == []`.
  And then, store it in the tabled entries map, and wakeup waiters. -/
def addAnswer (cNode : ConsumerNode) : SynthM Unit := do
  withMCtx cNode.mctx do
  if cNode.size ≥ (← read).maxResultSize then
      trace[Meta.synthInstance.answer] "{crossEmoji} {← instantiateMVars (← inferType cNode.mvar)}{Format.line}(size: {cNode.size} ≥ {(← read).maxResultSize})"
  else
    withTraceNode `Meta.synthInstance.answer
      (fun _ => return m!"{checkEmoji} {← instantiateMVars (← inferType cNode.mvar)}") do
    let answer ← mkAnswer cNode
    -- Remark: `answer` does not contain assignable or assigned metavariables.
    let key := cNode.key
    let entry ← getEntry key
    if isNewAnswer entry.answers answer then
      let newEntry := { entry with answers := entry.answers.push answer }
      modify fun s => { s with tableEntries := s.tableEntries.insert key newEntry }
      entry.waiters.forM (wakeUp answer)

/--
  Return `true` if a type of the form `(a_1 : A_1) → ... → (a_n : A_n) → B` has an unused argument `a_i`.

  Remark: This is syntactic check and no reduction is performed.
-/
private def hasUnusedArguments : Expr → Bool
  | Expr.forallE _ _ b _ => !b.hasLooseBVar 0 || hasUnusedArguments b
  | _ => false

/--
  If the type of the metavariable `mvar` has unused argument, return a pair `(α, transformer)`
  where `α` is a new type without the unused arguments and the `transformer` is a function for coverting a
  solution with type `α` into a value that can be assigned to `mvar`.
  Example: suppose `mvar` has type `(a : A) → (b : B a) → (c : C a) → D a c`, the result is the pair
  ```
  ((a : A) → (c : C a) → D a c,
   fun (f : (a : A) → (c : C a) → D a c) (a : A) (b : B a) (c : C a) => f a c
  )
  ```

  This method is used to improve the effectiveness of the TC resolution procedure. It was suggested and prototyped by
  Tomas Skrivan. It improves the support for instances of type `a : A → C` where `a` does not appear in class `C`.
  When we look for such an instance it is enough to look for an instance `c : C` and then return `fun _ => c`.

  Tomas' approach makes sure that instance of a type like `a : A → C` never gets tabled/cached. More on that later.
  At the core is this method. it takes an expression E and does two things:

  The modification to TC resolution works this way: We are looking for an instance of `E`, if it is tabled
  just get it as normal, but if not first remove all unused arguments producing `E'`. Now we look up the table again but
  for `E'`. If it exists, use the transformer to create E. If it does not exists, create a new goal `E'`.
-/
private def removeUnusedArguments? (mctx : MetavarContext) (mvar : Expr) : MetaM (Option (Expr × Expr)) :=
  withMCtx mctx do
    let mvarType ← instantiateMVars (← inferType mvar)
    if !hasUnusedArguments mvarType then
      return none
    else
      forallTelescope mvarType fun xs body => do
        let ys ← xs.foldrM (init := []) fun x ys => do
          if body.containsFVar x.fvarId! then
            return x :: ys
          else if (← ys.anyM fun y => return (← inferType y).containsFVar x.fvarId!) then
            return x :: ys
          else
            return ys
        let ys := ys.toArray
        let mvarType' ← mkForallFVars ys body
        withLocalDeclD `redf mvarType' fun f => do
          let transformer ← mkLambdaFVars #[f] (← mkLambdaFVars xs (mkAppN f ys))
          trace[Meta.synthInstance.unusedArgs] "{mvarType}\nhas unused arguments, reduced type{indentExpr mvarType'}\nTransformer{indentExpr transformer}"
          return some (mvarType', transformer)

/-- Process the next subgoal in the given consumer node. -/
def consume (cNode : ConsumerNode) : SynthM Unit := do
  /- Filter out subgoals that have already been assigned when solving typing constraints.
    This may happen when a local instance type depends on other local instances.
    For example, in Mathlib, we have
    ```
    @Submodule.setLike : {R : Type u_1} → {M : Type u_2} →
      [_inst_1 : Semiring R] →
      [_inst_2 : AddCommMonoid M] →
      [_inst_3 : @ModuleS R M _inst_1 _inst_2] →
      SetLike (@Submodule R M _inst_1 _inst_2 _inst_3) M
    ```
  -/
  let cNode := { cNode with
    subgoals := ← withMCtx cNode.mctx do
      cNode.subgoals.filterM (not <$> ·.mvarId!.isAssigned)
  }
  match cNode.subgoals with
  | []      => addAnswer cNode
  | mvar::_ =>
     let waiter := Waiter.consumerNode cNode
     let key ← mkTableKeyFor cNode.mctx mvar
     let entry? ← findEntry? key
     match entry? with
     | none       =>
       -- Remove unused arguments and try again, see comment at `removeUnusedArguments?`
       match (← removeUnusedArguments? cNode.mctx mvar) with
       | none => newSubgoal cNode.mctx key mvar waiter
       | some (mvarType', transformer) =>
         let key' ← withMCtx cNode.mctx <| mkTableKey mvarType'
         match (← findEntry? key') with
         | none =>
           let (mctx', mvar') ← withMCtx cNode.mctx do
             let mvar' ← mkFreshExprMVar mvarType'
             return (← getMCtx, mvar')
           newSubgoal mctx' key' mvar' (Waiter.consumerNode { cNode with mctx := mctx', subgoals := mvar'::cNode.subgoals })
         | some entry' =>
           let answers' ← entry'.answers.mapM fun a => withMCtx cNode.mctx do
             let trAnswr := Expr.betaRev transformer #[← instantiateMVars a.result.expr]
             let trAnswrType ← inferType trAnswr
             pure { a with result.expr := trAnswr, resultType := trAnswrType }
           modify fun s =>
             { s with
               resumeStack  := answers'.foldl (fun s answer => s.push (cNode, answer)) s.resumeStack,
               tableEntries := s.tableEntries.insert key' { entry' with waiters := entry'.waiters.push waiter } }
     | some entry => modify fun s =>
       { s with
         resumeStack  := entry.answers.foldl (fun s answer => s.push (cNode, answer)) s.resumeStack,
         tableEntries := s.tableEntries.insert key { entry with waiters := entry.waiters.push waiter } }

def getTop : SynthM GeneratorNode :=
  return (← get).generatorStack.back

@[inline] def modifyTop (f : GeneratorNode → GeneratorNode) : SynthM Unit :=
  modify fun s => { s with generatorStack := s.generatorStack.modify (s.generatorStack.size - 1) f }

/-- Try the next instance in the node on the top of the generator stack. -/
def generate : SynthM Unit := do
  let gNode ← getTop
  if gNode.currInstanceIdx == 0  then
    modify fun s => { s with generatorStack := s.generatorStack.pop }
  else
    let key  := gNode.key
    let idx  := gNode.currInstanceIdx - 1
    let inst := gNode.instances.get! idx
    let mctx := gNode.mctx
    let mvar := gNode.mvar
    discard do withMCtx mctx do
      withTraceNode `Meta.synthInstance
        (return m!"{exceptOptionEmoji ·} apply {inst} to {← instantiateMVars (← inferType mvar)}") do
      modifyTop fun gNode => { gNode with currInstanceIdx := idx }
      if let some (mctx, subgoals) ← tryResolve mvar inst then
        consume { key, mvar, subgoals, mctx, size := 0 }
        return some ()
      return none

def getNextToResume : SynthM (ConsumerNode × Answer) := do
  let r := (← get).resumeStack.back
  modify fun s => { s with resumeStack := s.resumeStack.pop }
  return r

/--
  Given `(cNode, answer)` on the top of the resume stack, continue execution by using `answer` to solve the
  next subgoal. -/
def resume : SynthM Unit := do
  let (cNode, answer) ← getNextToResume
  match cNode.subgoals with
  | []         => panic! "resume found no remaining subgoals"
  | mvar::rest =>
    match (← tryAnswer cNode.mctx mvar answer) with
    | none      => return ()
    | some mctx =>
      withMCtx mctx do
      let goal    ← inferType cNode.mvar
      let subgoal ← inferType mvar
      withTraceNode `Meta.synthInstance.resume
        (fun _ => withMCtx cNode.mctx do
          return m!"propagating {← instantiateMVars answer.resultType} to subgoal {← instantiateMVars subgoal} of {← instantiateMVars goal}") do
      trace[Meta.synthInstance.resume] "size: {cNode.size + answer.size}"
      consume { key := cNode.key, mvar := cNode.mvar, subgoals := rest, mctx, size := cNode.size + answer.size }

def step : SynthM Bool := do
  checkMaxHeartbeats
  let s ← get
  if !s.resumeStack.isEmpty then
    resume
    return true
  else if !s.generatorStack.isEmpty then
    generate
    return true
  else
    return false

def getResult : SynthM (Option AbstractMVarsResult) :=
  return (← get).result?

partial def synth : SynthM (Option AbstractMVarsResult) := do
  if (← step) then
    match (← getResult) with
    | none        => synth
    | some result => return result
  else
    return none

def main (type : Expr) (maxResultSize : Nat) : MetaM (Option AbstractMVarsResult) :=
  withCurrHeartbeats do
     let mvar ← mkFreshExprMVar type
     let key  ← mkTableKey type
     let action : SynthM (Option AbstractMVarsResult) := do
       newSubgoal (← getMCtx) key mvar Waiter.root
       synth
     try
       action.run { maxResultSize := maxResultSize, maxHeartbeats := getMaxHeartbeats (← getOptions) } |>.run' {}
     catch ex =>
       if ex.isMaxHeartbeat then
         throwError "failed to synthesize{indentExpr type}\n{ex.toMessageData}"
       else
         throw ex

end SynthInstance

/-!
Type class parameters can be annotated with `outParam` annotations.

Given `C a_1 ... a_n`, we replace `a_i` with a fresh metavariable `?m_i` IF
`a_i` is an `outParam`.
The result is type correct because we reject type class declarations IF
it contains a regular parameter X that depends on an `out` parameter Y.

Then, we execute type class resolution as usual.
If it succeeds, and metavariables ?m_i have been assigned, we try to unify
the original type `C a_1 ... a_n` witht the normalized one.
-/

private def preprocess (type : Expr) : MetaM Expr :=
  forallTelescopeReducing type fun xs type => do
    let type ← whnf type
    mkForallFVars xs type

private def preprocessLevels (us : List Level) : MetaM (List Level × Bool) := do
  let mut r := #[]
  let mut modified := false
  for u in us do
    let u ← instantiateLevelMVars u
    if u.hasMVar then
      r := r.push (← mkFreshLevelMVar)
      modified := true
    else
      r := r.push u
  return (r.toList, modified)

private partial def preprocessArgs (type : Expr) (i : Nat) (args : Array Expr) (outParamsPos : Array Nat) : MetaM (Array Expr) := do
  if h : i < args.size then
    let type ← whnf type
    match type with
    | .forallE _ d b _ => do
      let arg := args.get ⟨i, h⟩
      /-
      We should not simply check `d.isOutParam`. See `checkOutParam` and issue #1852.
      If an instance implicit argument depends on an `outParam`, it is treated as an `outParam` too.
      -/
      let arg ← if outParamsPos.contains i then mkFreshExprMVar d else pure arg
      let args := args.set ⟨i, h⟩ arg
      preprocessArgs (b.instantiate1 arg) (i+1) args outParamsPos
    | _ =>
      throwError "type class resolution failed, insufficient number of arguments" -- TODO improve error message
  else
    return args

private def preprocessOutParam (type : Expr) : MetaM Expr :=
  forallTelescope type fun xs typeBody => do
    match typeBody.getAppFn with
    | c@(Expr.const declName _) =>
      let env ← getEnv
      if let some outParamsPos := getOutParamPositions? env declName then
        unless outParamsPos.isEmpty do
          let args := typeBody.getAppArgs
          let cType ← inferType c
          let args ← preprocessArgs cType 0 args outParamsPos
          return (← mkForallFVars xs (mkAppN c args))
      return type
    | _ =>
      return type

/-!
  Remark: when `maxResultSize? == none`, the configuration option `synthInstance.maxResultSize` is used.
  Remark: we use a different option for controlling the maximum result size for coercions.
-/

def synthInstance? (type : Expr) (maxResultSize? : Option Nat := none) : MetaM (Option Expr) := do profileitM Exception "typeclass inference" (← getOptions) (decl := type.getAppFn.constName?.getD .anonymous) do
  let opts ← getOptions
  let maxResultSize := maxResultSize?.getD (synthInstance.maxSize.get opts)
  withTraceNode `Meta.synthInstance
    (return m!"{exceptOptionEmoji ·} {← instantiateMVars type}") do
  /-
    We disable eta for structures that are not classes during TC resolution because it allows us to find unintended solutions.
    See discussion at
      https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/.60constructor.60.20and.20.60Applicative.60/near/279984801
  -/
  let etaStruct := if synthInstance.etaExperiment.get (← getOptions) then .all else .notClasses
  withConfig (fun config => { config with isDefEqStuckEx := true, transparency := TransparencyMode.instances,
                                          foApprox := true, ctxApprox := true, constApprox := false,
                                          etaStruct }) do
    let localInsts ← getLocalInstances
    let type ← instantiateMVars type
    let type ← preprocess type
    let s ← get
    let rec assignOutParams (result : Expr) : MetaM Bool := do
      let resultType ← inferType result
      /- Output parameters of local instances may be marked as `syntheticOpaque` by the application-elaborator.
         We use `withAssignableSyntheticOpaque` to make sure this kind of parameter can be assigned by the following `isDefEq`.
         TODO: rewrite this check to avoid `withAssignableSyntheticOpaque`. -/
      let defEq ← withDefault <| withAssignableSyntheticOpaque <| isDefEq type resultType
      unless defEq do
        trace[Meta.synthInstance] "{crossEmoji} result type{indentExpr resultType}\nis not definitionally equal to{indentExpr type}"
      return defEq
    match s.cache.synthInstance.find? (localInsts, type) with
    | some result =>
      trace[Meta.synthInstance] "result {result} (cached)"
      if let some inst := result then
        unless (← assignOutParams inst) do
          return none
      pure result
    | none        =>
      let result? ← withNewMCtxDepth (allowLevelAssignments := true) do
        let normType ← preprocessOutParam type
        SynthInstance.main normType maxResultSize
      let result? ← match result? with
        | none        => pure none
        | some result => do
          let (_, _, result) ← openAbstractMVarsResult result
          trace[Meta.synthInstance] "result {result}"
          if (← assignOutParams result) then
            let result ← instantiateMVars result
            /- We use `check` to propogate universe constraints implied by the `result`.
               Recall that we use `allowLevelAssignments := true` which allows universe metavariables in the current depth to be assigned,
               but these assignments are discarded by `withNewMCtxDepth`.

               TODO: If this `check` is a performance bottleneck, we can improve performance by tracking whether
                     a universe metavariable from previous universe levels have been assigned or not during TC resolution.
                     We only need to perform the `check` if this kind of assignment have been performed.

               The example in the issue #796 exposed this issue.
               ```
                structure A
                class B (a : outParam A) (α : Sort u)
                class C {a : A} (α : Sort u) [B a α]
                class D {a : A} (α : Sort u) [B a α] [c : C α]
                class E (a : A) where [c (α : Sort u) [B a α] : C α]
                instance c {a : A} [e : E a] (α : Sort u) [B a α] : C α := e.c α

                def d {a : A} [e : E a] (α : Sort u) [b : B a α] : D α := ⟨⟩
               ```
               The term `D α` has two instance implicit arguments. The second one has type `C α`, and TC
               resolution produces the result `@c.{u} a e α b`.
               Note that the `e` has type `E.{?v} a`, and `E` is universe polymorphic,
               but the universe does not occur in the parameter `a`. We have that `?v := u` is implied by `@c.{u} a e α b`,
               but this assignment is lost.
            -/
            check result
            pure (some result)
          else
            pure none
      modify fun s => { s with cache.synthInstance := s.cache.synthInstance.insert (localInsts, type) result? }
      pure result?

/--
  Return `LOption.some r` if succeeded, `LOption.none` if it failed, and `LOption.undef` if
  instance cannot be synthesized right now because `type` contains metavariables. -/
def trySynthInstance (type : Expr) (maxResultSize? : Option Nat := none) : MetaM (LOption Expr) := do
  catchInternalId isDefEqStuckExceptionId
    (toLOptionM <| synthInstance? type maxResultSize?)
    (fun _ => pure LOption.undef)

def synthInstance (type : Expr) (maxResultSize? : Option Nat := none) : MetaM Expr :=
  catchInternalId isDefEqStuckExceptionId
    (do
      let result? ← synthInstance? type maxResultSize?
      match result? with
      | some result => pure result
      | none        => throwError "failed to synthesize{indentExpr type}")
    (fun _ => throwError "failed to synthesize{indentExpr type}")

@[export lean_synth_pending]
private def synthPendingImp (mvarId : MVarId) : MetaM Bool := withIncRecDepth <| mvarId.withContext do
  let mvarDecl ← mvarId.getDecl
  match mvarDecl.kind with
  | MetavarKind.syntheticOpaque =>
    return false
  | _ =>
    /- Check whether the type of the given metavariable is a class or not. If yes, then try to synthesize
       it using type class resolution. We only do it for `synthetic` and `natural` metavariables. -/
    match (← isClass? mvarDecl.type) with
    | none   =>
      return false
    | some _ =>
      /- TODO: use a configuration option instead of the hard-coded limit `1`. -/
      if (← read).synthPendingDepth > 1 then
        trace[Meta.synthPending] "too many nested synthPending invocations"
        return false
      else
        withReader (fun ctx => { ctx with synthPendingDepth := ctx.synthPendingDepth + 1 }) do
          trace[Meta.synthPending] "synthPending {mkMVar mvarId}"
          let val? ← catchInternalId isDefEqStuckExceptionId (synthInstance? mvarDecl.type (maxResultSize? := none)) (fun _ => pure none)
          match val? with
          | none     =>
            return false
          | some val =>
            if (← mvarId.isAssigned) then
              return false
            else
              mvarId.assign val
              return true

builtin_initialize
  registerTraceClass `Meta.synthPending
  registerTraceClass `Meta.synthInstance
  registerTraceClass `Meta.synthInstance.instances (inherited := true)
  registerTraceClass `Meta.synthInstance.tryResolve (inherited := true)
  registerTraceClass `Meta.synthInstance.resume (inherited := true)
  registerTraceClass `Meta.synthInstance.unusedArgs
  registerTraceClass `Meta.synthInstance.newAnswer

end Lean.Meta


import category_theory.limits.fubini

open category_theory

namespace category_theory.limits

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

noncomputable
def limit_flip_comp_lim_iso_limit_comp_lim'
  {J : Type*} [category J]
  [has_limits_of_shape J C]
  {K : Type*} [category K]
  [has_limits_of_shape K C]
  (F : J ⥤ K ⥤ C) : limit (F.flip ⋙ lim) ≅ limit (F ⋙ lim) :=
{ hom := limit.lift (F ⋙ lim) ⟨limit (F.flip ⋙ lim),
  { app := λ j, limit.lift (F.obj j) ⟨limit (F.flip ⋙ lim),
    { app := λ k, limit.π _ k ≫ limit.π _ j,
      naturality' := begin
        intros k1 k2 f,
        dsimp, simp only [category.id_comp, category.assoc],
        rw ← limit.w _ f,
        simp,
      end }⟩,
    naturality' := begin
      intros j1 j2 f,
      ext,
      dsimp,
      simp only [category.id_comp, category.assoc, limit.lift_π, limit.lift_map,
        cones.postcompose_obj_π, nat_trans.comp_app],
      rw ← limit.w _ f,
      refl,
    end }⟩,
  inv := limit.lift (F.flip ⋙ lim) ⟨limit (F ⋙ lim),
  { app := λ k, limit.lift (F.flip.obj k) ⟨limit (F ⋙ lim),
    { app := λ j, limit.π _ j ≫ limit.π _ k,
      naturality' := begin
        intros j1 j2 f,
        dsimp, simp only [category.id_comp, category.assoc],
        rw ← limit.w _ f,
        simp,
      end }⟩,
    naturality' := begin
      intros k1 k2 f,
      ext,
      dsimp,
      simp only [category.id_comp, category.assoc, limit.lift_π, limit.lift_map,
        cones.postcompose_obj_π, nat_trans.comp_app],
      rw ← limit.w _ f,
      refl,
    end }⟩,
  hom_inv_id' := begin
    ext, dsimp, simp,
  end,
  inv_hom_id' := begin
    ext, dsimp, simp,
  end }

.

@[simp, reassoc]
lemma limit_flip_comp_lim_iso_limit_comp_lim'_hom_π_π {J : Type*} [category J]
  [has_limits_of_shape J C]
  {K : Type*} [category K]
  [has_limits_of_shape K C]
  (F : J ⥤ K ⥤ C) (j) (k) :
  (limit_flip_comp_lim_iso_limit_comp_lim' F).hom ≫ limit.π _ j ≫ limit.π _ k =
  limit.π _ k ≫ limit.π _ j :=
begin
  dsimp [limit_flip_comp_lim_iso_limit_comp_lim'],
  simp,
end

@[simp, reassoc]
lemma limit_flip_comp_lim_iso_limit_comp_lim'_inv_π_π {J : Type*} [category J]
  [has_limits_of_shape J C]
  {K : Type*} [category K]
  [has_limits_of_shape K C]
  (F : J ⥤ K ⥤ C) (j) (k) :
  (limit_flip_comp_lim_iso_limit_comp_lim' F).inv ≫ limit.π _ j ≫ limit.π _ k =
  limit.π _ k ≫ limit.π _ j :=
begin
  dsimp [limit_flip_comp_lim_iso_limit_comp_lim'],
  simp,
end

end category_theory.limits