split off test game
still need to adapt the call to the lean binary to provide two arguments
This commit is contained in:
Alexander Bentkamp
@@ -0,0 +1,229 @@
|
||||
import Lean
|
||||
|
||||
import GameServer.Utils
|
||||
import GameServer.EnvExtensions
|
||||
|
||||
open Lean Meta
|
||||
|
||||
set_option autoImplicit false
|
||||
|
||||
/-! ## Easy metadata -/
|
||||
|
||||
section metadata
|
||||
|
||||
open Lean Meta Elab Command Term
|
||||
|
||||
/-- Create a game with the given identifier as name. -/
|
||||
elab "Game" n:str : command => do
|
||||
gameExt.set {name := n.getString}
|
||||
|
||||
/-- Define the current level number. -/
|
||||
elab "Level" n:num : command => do
|
||||
let idx := n.getNat
|
||||
setCurLevelIdx idx
|
||||
levelsExt.insert idx {index := idx}
|
||||
|
||||
/-- Define the title of the current game or current level if some
|
||||
building a level. -/
|
||||
elab "Title" t:str : command => do
|
||||
let lvlIdx ← getCurLevelIdx
|
||||
if lvlIdx > 0 then
|
||||
let some lvl := (← levelsExt.find? lvlIdx) | throwError "Unable to find level"
|
||||
levelsExt.update lvlIdx {lvl with title := t.getString}
|
||||
else
|
||||
gameExt.set {← gameExt.get with title := t.getString}
|
||||
|
||||
/-- Define the introduction of the current game or current level if some
|
||||
building a level. -/
|
||||
elab "Introduction" t:str : command => do
|
||||
let lvlIdx ← getCurLevelIdx
|
||||
if lvlIdx > 0 then
|
||||
let some lvl := (← levelsExt.find? lvlIdx) | throwError "Unable to find level"
|
||||
levelsExt.update lvlIdx {lvl with introduction := t.getString}
|
||||
else
|
||||
gameExt.set {← gameExt.get with introduction := t.getString}
|
||||
|
||||
/-- Define the statement of the current level. -/
|
||||
elab "Statement" sig:declSig val:declVal : command => do
|
||||
let lvlIdx ← getCurLevelIdx
|
||||
let declName : Name := (← gameExt.get).name ++ ("level" ++ toString lvlIdx : String)
|
||||
elabCommand (← `(theorem $(mkIdent declName) $sig $val))
|
||||
let (binders, _) := expandDeclSig sig
|
||||
let mut nb : Nat := 0
|
||||
for arg in binders.getArgs do
|
||||
nb := nb + arg[1].getArgs.size
|
||||
let some cInfo := (← getEnv).find? declName | throwError "Declaration not found"
|
||||
levelsExt.update lvlIdx {← getCurLevel with goal := cInfo.type, intro_nb := nb}
|
||||
|
||||
/-- Define the conclusion of the current game or current level if some
|
||||
building a level. -/
|
||||
elab "Conclusion" t:str : command => do
|
||||
let lvlIdx ← getCurLevelIdx
|
||||
if lvlIdx > 0 then
|
||||
let some lvl := (← levelsExt.find? lvlIdx) | throwError "Unable to find level"
|
||||
levelsExt.update lvlIdx {lvl with conclusion := t.getString}
|
||||
else
|
||||
gameExt.set {← gameExt.get with conclusion := t.getString}
|
||||
|
||||
/-- Print current game for debugging purposes. -/
|
||||
elab "PrintCurGame" : command => do
|
||||
logInfo (repr (← gameExt.get))
|
||||
|
||||
/-- Print current level for debugging purposes. -/
|
||||
elab "PrintCurLevel" : command => do
|
||||
match ← levelsExt.find? (← getCurLevelIdx) with
|
||||
| some lvl => logInfo (repr lvl)
|
||||
| none => logInfo "Could not find level"
|
||||
|
||||
/-- Print levels for debugging purposes. -/
|
||||
elab "PrintLevels" : command => do
|
||||
logInfo $ repr $ (levelsExt.getState (← getEnv)).toList.map (·.fst)
|
||||
|
||||
end metadata
|
||||
|
||||
/-! ## Messages -/
|
||||
|
||||
open Lean Meta Elab Command Term
|
||||
|
||||
declare_syntax_cat mydecl
|
||||
syntax "(" ident ":" term ")" : mydecl
|
||||
|
||||
def getIdent : TSyntax `mydecl → Ident
|
||||
| `(mydecl| ($n:ident : $_t:term)) => n
|
||||
| _ => default
|
||||
|
||||
def getType : TSyntax `mydecl → Term
|
||||
| `(mydecl| ($_n:ident : $t:term)) => t
|
||||
| _ => default
|
||||
|
||||
/-- From a term `s` and a list of pairs `(i, t) ; Ident × Term`, create the syntax
|
||||
where `s` is preceded with universal quantifiers `∀ i : t`. -/
|
||||
def mkGoalSyntax (s : Term) : List (Ident × Term) → MacroM Term
|
||||
| (n, t)::tail => do return (← `(∀ $n : $t, $(← mkGoalSyntax s tail)))
|
||||
| [] => return s
|
||||
|
||||
/-- Declare a message. This version doesn't prevent the unused linter variable from running. -/
|
||||
local elab "Message'" decls:mydecl* ":" goal:term "=>" msg:str : command => do
|
||||
let g ← liftMacroM $ mkGoalSyntax goal (decls.map (λ decl => (getIdent decl, getType decl))).toList
|
||||
let g ← liftTermElabM do (return ← instantiateMVars (← elabTerm g none))
|
||||
let (ctx_size, normalized_goal) ← liftTermElabM do
|
||||
let msg_mvar ← mkFreshExprMVar g MetavarKind.syntheticOpaque
|
||||
msg_mvar.mvarId!.withContext do
|
||||
let (_, msg_mvar) ← msg_mvar.mvarId!.introNP decls.size
|
||||
return ((← msg_mvar.getDecl).lctx.size, (← normalizedRevertExpr msg_mvar))
|
||||
let lvlIdx ← getCurLevelIdx
|
||||
let lvl ← getCurLevel
|
||||
levelsExt.update lvlIdx {lvl with messages := lvl.messages.push {
|
||||
ctx_size := ctx_size,
|
||||
normalized_goal := normalized_goal,
|
||||
intro_nb := decls.size,
|
||||
message := msg.getString }}
|
||||
|
||||
/-- Declare a message in reaction to a given tactic state in the current level. -/
|
||||
macro "Message" decls:mydecl* ":" goal:term "=>" msg:str : command => do
|
||||
`(set_option linter.unusedVariables false in Message' $decls* : $goal => $msg)
|
||||
|
||||
|
||||
/-! ## Tactics -/
|
||||
|
||||
/-- Declare a documentation entry for some tactic.
|
||||
Expect an identifier and then a string literal. -/
|
||||
elab "TacticDoc" name:ident content:str : command =>
|
||||
modifyEnv (tacticDocExt.addEntry · {
|
||||
name := name.getId,
|
||||
content := content.getString })
|
||||
|
||||
/-- Declare a set of tactic documentation entries.
|
||||
Expect an identifier used as the set name then `:=` and a
|
||||
space separated list of identifiers.
|
||||
-/
|
||||
elab "TacticSet" name:ident ":=" args:ident* : command => do
|
||||
let docs := tacticDocExt.getState (← getEnv)
|
||||
let mut entries : Array TacticDocEntry := #[]
|
||||
for arg in args do
|
||||
let name := arg.getId
|
||||
match docs.find? (·.name = name) with
|
||||
| some doc => entries := entries.push doc
|
||||
| none => throwError "Documentation for tactic {name} wasn't found."
|
||||
modifyEnv (tacticSetExt.addEntry · {
|
||||
name := name.getId,
|
||||
tactics := entries })
|
||||
|
||||
instance : Quote TacticDocEntry `term :=
|
||||
⟨λ entry => Syntax.mkCApp ``TacticDocEntry.mk #[quote entry.name, quote entry.content]⟩
|
||||
|
||||
/-- Declare the list of tactics that will be displayed in the current level.
|
||||
Expects a space separated list of identifiers that refer to either a tactic doc
|
||||
entry or a tactic doc set. -/
|
||||
elab "Tactics" args:ident* : command => do
|
||||
let env ← getEnv
|
||||
let docs := tacticDocExt.getState env
|
||||
let sets := tacticSetExt.getState env
|
||||
let mut tactics : Array TacticDocEntry := #[]
|
||||
for arg in args do
|
||||
let name := arg.getId
|
||||
match docs.find? (·.name = name) with
|
||||
| some entry => tactics := tactics.push entry
|
||||
| none => match sets.find? (·.name = name) with
|
||||
| some entry => tactics := tactics ++ entry.tactics
|
||||
| none => throwError "Tactic doc or tactic set {name} wasn't found."
|
||||
let lvlIdx ← getCurLevelIdx
|
||||
if lvlIdx > 0 then
|
||||
let some lvl := (← levelsExt.find? lvlIdx) | throwError "Unable to find level"
|
||||
levelsExt.update lvlIdx {lvl with tactics := tactics}
|
||||
else
|
||||
throwError "This command can be used only while building a level."
|
||||
|
||||
/-! ## Lemmas -/
|
||||
|
||||
/-- Declare a documentation entry for some lemma.
|
||||
Expect two identifiers and then a string literal. The first identifier is meant
|
||||
as the real name of the lemma while the second is the displayed name. Currently
|
||||
the real name isn't used. -/
|
||||
elab "LemmaDoc" name:ident "as" userName:ident "in" category:str content:str : command =>
|
||||
modifyEnv (lemmaDocExt.addEntry · {
|
||||
name := name.getId,
|
||||
userName := userName.getId,
|
||||
category := category.getString,
|
||||
content := content.getString })
|
||||
|
||||
/-- Declare a set of lemma documentation entries.
|
||||
Expect an identifier used as the set name then `:=` and a
|
||||
space separated list of identifiers. -/
|
||||
elab "LemmaSet" name:ident ":" title:str ":=" args:ident* : command => do
|
||||
let docs := lemmaDocExt.getState (← getEnv)
|
||||
let mut entries : Array LemmaDocEntry := #[]
|
||||
for arg in args do
|
||||
let name := arg.getId
|
||||
match docs.find? (·.userName = name) with
|
||||
| some doc => entries := entries.push doc
|
||||
| none => throwError "Lemma doc {name} wasn't found."
|
||||
modifyEnv (lemmaSetExt.addEntry · {
|
||||
name := name.getId,
|
||||
title := title.getString,
|
||||
lemmas := entries })
|
||||
|
||||
instance : Quote LemmaDocEntry `term :=
|
||||
⟨λ entry => Syntax.mkCApp ``LemmaDocEntry.mk #[quote entry.name, quote entry.userName, quote entry.category, quote entry.content]⟩
|
||||
|
||||
/-- Declare the list of lemmas that will be displayed in the current level.
|
||||
Expects a space separated list of identifiers that refer to either a lemma doc
|
||||
entry or a lemma doc set. -/
|
||||
elab "Lemmas" args:ident* : command => do
|
||||
let env ← getEnv
|
||||
let docs := lemmaDocExt.getState env
|
||||
let sets := lemmaSetExt.getState env
|
||||
let mut lemmas : Array LemmaDocEntry := #[]
|
||||
for arg in args do
|
||||
let name := arg.getId
|
||||
match docs.find? (·.userName = name) with
|
||||
| some entry => lemmas := lemmas.push entry
|
||||
| none => match sets.find? (·.name = name) with
|
||||
| some entry => lemmas := lemmas ++ entry.lemmas
|
||||
| none => throwError "Lemma doc or lemma set {name} wasn't found."
|
||||
let lvlIdx ← getCurLevelIdx
|
||||
if lvlIdx > 0 then
|
||||
let some lvl := (← levelsExt.find? lvlIdx) | throwError "Unable to find level"
|
||||
levelsExt.update lvlIdx {lvl with lemmas := lemmas}
|
||||
else
|
||||
throwError "This command can be used only while building a level."
|
||||
@@ -0,0 +1,151 @@
|
||||
import GameServer.HashMapExtension
|
||||
import GameServer.SingleValPersistentEnvExtension
|
||||
|
||||
/-! # Environment extensions
|
||||
|
||||
The game framework stores almost all its game building data in environment extensions
|
||||
defined in this file. MAyn of them are `SimplePersistentEnvExtension` but we also
|
||||
use `HashMapExtension` and `SingleValPersistentEnvExtension`
|
||||
-/
|
||||
|
||||
|
||||
open Lean
|
||||
|
||||
/-! ## Messages -/
|
||||
|
||||
structure GoalMessageEntry where
|
||||
ctx_size : Nat
|
||||
normalized_goal : Expr
|
||||
intro_nb : Nat
|
||||
message : String
|
||||
deriving Repr
|
||||
|
||||
/-! ## Tactic documentation -/
|
||||
|
||||
structure TacticDocEntry where
|
||||
name : Name
|
||||
content : String
|
||||
deriving ToJson, Repr
|
||||
|
||||
/-- Environment extension for tactic documentation. -/
|
||||
initialize tacticDocExt : SimplePersistentEnvExtension TacticDocEntry (Array TacticDocEntry) ←
|
||||
registerSimplePersistentEnvExtension {
|
||||
name := `tactic_doc
|
||||
addEntryFn := Array.push
|
||||
addImportedFn := Array.concatMap id
|
||||
}
|
||||
|
||||
open Elab Command in
|
||||
/-- Print a registered tactic doc for debugging purposes. -/
|
||||
elab "#print_tactic_doc" : command => do
|
||||
for entry in tacticDocExt.getState (← getEnv) do
|
||||
dbg_trace "{entry.name} : {entry.content}"
|
||||
|
||||
structure TacticSetEntry where
|
||||
name : Name
|
||||
tactics : Array TacticDocEntry
|
||||
deriving ToJson, Repr
|
||||
|
||||
/-- Environment extension for tactic sets. -/
|
||||
initialize tacticSetExt : SimplePersistentEnvExtension TacticSetEntry (Array TacticSetEntry) ←
|
||||
registerSimplePersistentEnvExtension {
|
||||
name := `tactic_set
|
||||
addEntryFn := Array.push
|
||||
addImportedFn := Array.concatMap id
|
||||
}
|
||||
|
||||
open Elab Command in
|
||||
/-- Print all registered tactic sets for debugging purposes. -/
|
||||
elab "#print_tactic_set" : command => do
|
||||
for entry in tacticSetExt.getState (← getEnv) do
|
||||
dbg_trace "{entry.name} : {entry.tactics.map TacticDocEntry.name}"
|
||||
|
||||
/-! ## Lemma documentation -/
|
||||
|
||||
structure LemmaDocEntry where
|
||||
name : Name
|
||||
userName : Name
|
||||
category : String
|
||||
content : String
|
||||
deriving ToJson, Repr
|
||||
|
||||
/-- Environment extension for lemma documentation. -/
|
||||
initialize lemmaDocExt : SimplePersistentEnvExtension LemmaDocEntry (Array LemmaDocEntry) ←
|
||||
registerSimplePersistentEnvExtension {
|
||||
name := `lemma_doc
|
||||
addEntryFn := Array.push
|
||||
addImportedFn := Array.concatMap id
|
||||
}
|
||||
|
||||
open Elab Command in
|
||||
/-- Print a lemma doc for debugging purposes. -/
|
||||
elab "#print_lemma_doc" : command => do
|
||||
for entry in lemmaDocExt.getState (← getEnv) do
|
||||
dbg_trace "{entry.userName} ({entry.name}) in {entry.category}: {entry.content}"
|
||||
|
||||
structure LemmaSetEntry where
|
||||
name : Name
|
||||
title : String
|
||||
lemmas : Array LemmaDocEntry
|
||||
deriving ToJson, Repr
|
||||
|
||||
/-- Environment extension for lemma sets. -/
|
||||
initialize lemmaSetExt : SimplePersistentEnvExtension LemmaSetEntry (Array LemmaSetEntry) ←
|
||||
registerSimplePersistentEnvExtension {
|
||||
name := `lemma_set
|
||||
addEntryFn := Array.push
|
||||
addImportedFn := Array.concatMap id
|
||||
}
|
||||
|
||||
open Elab Command in
|
||||
/-- Print all registered lemma sets for debugging purposes. -/
|
||||
elab "#print_lemma_set" : command => do
|
||||
for entry in lemmaSetExt.getState (← getEnv) do
|
||||
dbg_trace "{entry.name} : {entry.lemmas.map LemmaDocEntry.name}"
|
||||
|
||||
/-! ## Game -/
|
||||
|
||||
structure Game where
|
||||
name : Name
|
||||
title : String := ""
|
||||
introduction : String := ""
|
||||
conclusion : String := ""
|
||||
authors : List String := []
|
||||
nb_levels : Nat := 0
|
||||
deriving Repr, Inhabited, ToJson
|
||||
|
||||
initialize gameExt : SingleValPersistentEnvExtension Game ← registerSingleValPersistentEnvExtension `gameExt Game
|
||||
|
||||
/-! ## Levels -/
|
||||
|
||||
/- Register a (non-persistent) environment extension to hold the current level number. -/
|
||||
initialize curLevelExt : EnvExtension Nat ← registerEnvExtension (pure 0)
|
||||
|
||||
variable {m: Type → Type} [Monad m] [MonadEnv m]
|
||||
|
||||
def setCurLevelIdx (lvl : Nat) : m Unit :=
|
||||
modifyEnv (curLevelExt.setState · lvl)
|
||||
|
||||
def getCurLevelIdx : m Nat := do
|
||||
return curLevelExt.getState (← getEnv)
|
||||
|
||||
structure GameLevel where
|
||||
index: Nat
|
||||
title: String := default
|
||||
introduction: String := default
|
||||
conclusion: String := default
|
||||
tactics: Array TacticDocEntry := default
|
||||
lemmas: Array LemmaDocEntry := default
|
||||
messages: Array GoalMessageEntry := default
|
||||
goal : Expr := default
|
||||
intro_nb : Nat := default
|
||||
deriving Inhabited, Repr
|
||||
|
||||
initialize levelsExt : HashMapExtension Nat GameLevel ← mkHashMapExtension `levels Nat GameLevel
|
||||
|
||||
def getCurLevel [MonadError m] : m GameLevel := do
|
||||
let idx ← getCurLevelIdx
|
||||
match (← levelsExt.find? idx) with
|
||||
| some level => return level
|
||||
| none => throwError "Couldn't find level {idx}"
|
||||
|
||||
@@ -0,0 +1,31 @@
|
||||
import Lean
|
||||
|
||||
open Lean Std
|
||||
|
||||
def HashMapExtension (α β : Type) [BEq α] [Hashable α] := SimplePersistentEnvExtension (α × β) (HashMap α β)
|
||||
|
||||
instance (α β : Type) [BEq α] [Hashable α] : Inhabited (HashMapExtension α β) :=
|
||||
inferInstanceAs (Inhabited (SimplePersistentEnvExtension (α × β) (HashMap α β)))
|
||||
|
||||
def mkHashMapExtension (name : Name) (α β : Type) [BEq α] [Hashable α] : IO (HashMapExtension α β) :=
|
||||
registerSimplePersistentEnvExtension {
|
||||
name := name,
|
||||
addImportedFn := mkStateFromImportedEntries (λ s n => s.insert n.1 n.2) {},
|
||||
addEntryFn := (λ s n => s.insert n.1 n.2),
|
||||
toArrayFn := fun es => es.toArray
|
||||
}
|
||||
|
||||
namespace HashMapExtension
|
||||
|
||||
variable {α β : Type} [BEq α] [Hashable α] {m: Type → Type} [Monad m] [MonadEnv m]
|
||||
|
||||
def find? (ext : HashMapExtension α β) (a : α) : m $ Option β := do
|
||||
return (ext.getState (← getEnv)).find? a
|
||||
|
||||
def insert (ext : HashMapExtension α β) (a : α) (b : β) : m Unit :=
|
||||
modifyEnv (ext.addEntry · (a, b))
|
||||
|
||||
def update (ext : HashMapExtension α β) (a : α) (b : β) : m Unit :=
|
||||
modifyEnv (ext.addEntry · (a, b))
|
||||
|
||||
end HashMapExtension
|
||||
@@ -0,0 +1,243 @@
|
||||
/-
|
||||
This is the Lean 4 game server. It offers a way to interact with Lean 4 which
|
||||
is completely distinct from running the command-line lean or the language server protocol.
|
||||
|
||||
It is based on lean-gym by Daniel Selsam.
|
||||
-/
|
||||
import Lean.Data.Json.Basic
|
||||
|
||||
import GameServer.Utils
|
||||
import GameServer.EnvExtensions
|
||||
|
||||
open Lean Meta Elab Tactic Std
|
||||
|
||||
/- Convert JSON to string without line breaks -/
|
||||
-- TODO: this is too slow...
|
||||
instance instToStringJsonOneLine : ToString Json := ToString.mk (fun o => (toString o).replace "\n" "")
|
||||
attribute [-instance] Lean.Json.instToStringJson
|
||||
|
||||
/-! ## GameGoal -/
|
||||
structure GameGoal where
|
||||
objects : List LocalDecl
|
||||
assumptions : List LocalDecl
|
||||
goal : String
|
||||
mvarid : MVarId
|
||||
|
||||
def Lean.MVarId.toGameGoal (goal : MVarId) : MetaM GameGoal := do
|
||||
match (← getMCtx).findDecl? goal with
|
||||
| none => throwError "unknown goal"
|
||||
| some mvarDecl => do
|
||||
-- toGameGoalAux below will sort local declarations from the context of goal into data and assumptions,
|
||||
-- discarding auxilliary declarations
|
||||
let rec toGameGoalAux : List (Option LocalDecl) → MetaM (List LocalDecl × List LocalDecl)
|
||||
| (some decl)::t => withLCtx mvarDecl.lctx mvarDecl.localInstances do
|
||||
let (o, a) ← toGameGoalAux t
|
||||
if decl.isAuxDecl then
|
||||
return (o, a)
|
||||
if (← inferType decl.type).isProp then
|
||||
return (o, decl::a)
|
||||
else
|
||||
return (decl::o, a)
|
||||
| none:: t => toGameGoalAux t
|
||||
| [] => return ([], [])
|
||||
withLCtx mvarDecl.lctx mvarDecl.localInstances do
|
||||
let (objects, assumptions) ← toGameGoalAux mvarDecl.lctx.decls.toList
|
||||
return {objects := objects, assumptions := assumptions, goal := toString (← Meta.ppExpr mvarDecl.type),
|
||||
mvarid := goal }
|
||||
|
||||
def GameGoal.toJson (gameGoal : GameGoal) : MetaM Json :=
|
||||
gameGoal.mvarid.withContext do
|
||||
return Json.mkObj [("objects", Lean.ToJson.toJson (← gameGoal.objects.mapM Lean.LocalDecl.toJson)),
|
||||
("assumptions", Lean.ToJson.toJson (← gameGoal.assumptions.mapM Lean.LocalDecl.toJson)),
|
||||
("goal", gameGoal.goal)]
|
||||
|
||||
|
||||
/-! ## Action -/
|
||||
|
||||
inductive Action where
|
||||
| info : Action
|
||||
| loadLevel : Nat → Action
|
||||
| runTactic : String → Action
|
||||
| undo : Action
|
||||
| restartGame : Action
|
||||
| restartLevel : Action
|
||||
| quit : Action
|
||||
| next : Action
|
||||
| prev : Action
|
||||
| invalid : String → Action -- Used for broken Json parsing
|
||||
deriving ToJson, FromJson, Repr
|
||||
|
||||
def Action.parse (s : String) : Action :=
|
||||
let e : Except String Action :=
|
||||
try
|
||||
return ← fromJson? (← Json.parse s)
|
||||
catch _ => return Action.invalid s
|
||||
match e with
|
||||
| Except.ok a => a
|
||||
| _ => Action.info
|
||||
|
||||
def Action.get : IO Action :=
|
||||
return Action.parse (← (← IO.getStdin).getLine)
|
||||
|
||||
|
||||
/-! ## LevelInfo -/
|
||||
|
||||
structure LevelInfo extends GameLevel where
|
||||
goals : List GameGoal := []
|
||||
errors : Array String := #[]
|
||||
message : String := ""
|
||||
|
||||
def LevelInfo.toJson (info : LevelInfo) : MetaM Json :=
|
||||
return Json.mkObj [("index", Lean.ToJson.toJson info.index),
|
||||
("title", Lean.ToJson.toJson info.title),
|
||||
("tactics", Lean.ToJson.toJson info.tactics),
|
||||
("lemmas", Lean.ToJson.toJson info.lemmas),
|
||||
("errors", Lean.ToJson.toJson info.errors),
|
||||
("goals", Lean.ToJson.toJson (← info.goals.mapM (·.toJson))),
|
||||
("message", info.message)]
|
||||
|
||||
namespace Server
|
||||
|
||||
/-! ## LevelM and Response -/
|
||||
|
||||
structure SavedState where
|
||||
tacticState : Tactic.SavedState
|
||||
message : String := ""
|
||||
|
||||
abbrev LevelM := ReaderT GameLevel StateRefT (Array SavedState) TermElabM
|
||||
|
||||
/-- Returns the most recent SavedState. -/
|
||||
def getState : LevelM SavedState := do
|
||||
let some state := (← get).back? | throwError "Couldn't find tactic state"
|
||||
return state
|
||||
|
||||
|
||||
structure Response : Type where
|
||||
goals : List GameGoal := []
|
||||
errors : Array String := #[]
|
||||
message : String := ""
|
||||
|
||||
def Response.toJson (resp : Response) : MetaM Json :=
|
||||
return Json.mkObj [("errors", Lean.ToJson.toJson resp.errors),
|
||||
("goals", Lean.ToJson.toJson (← resp.goals.mapM (·.toJson))),
|
||||
("message", resp.message)]
|
||||
|
||||
/-! ## Main running functions -/
|
||||
|
||||
/-- Dummy `Core.Context` value to be fed to `Lean.Core.CoreM.toIO` -/
|
||||
def coreCtx : Core.Context := {
|
||||
currNamespace := Name.anonymous,
|
||||
openDecls := [],
|
||||
fileName := "<Game>",
|
||||
fileMap := { source := "", positions := #[0], lines := #[1] } }
|
||||
|
||||
|
||||
partial def runLevel (GameName : Name) (levels : HashMap Nat GameLevel) (idx : Nat) : IO Unit := do
|
||||
let levelName : Name := s!"Level{toString idx}"
|
||||
let termElabM : TermElabM Unit := do
|
||||
let some lvl := levels.find? idx | throwError s!"Cannot find level {idx}"
|
||||
let mvar ← mkFreshExprMVar (some lvl.goal) (kind := MetavarKind.synthetic)
|
||||
let (_, mvar) ← mvar.mvarId!.introNP lvl.intro_nb
|
||||
mvar.withContext do
|
||||
let state := #[{tacticState := { term := ← Term.saveState, tactic := { goals := [mvar] }}}]
|
||||
let levelM : LevelM Unit := do
|
||||
let resp := {← mkResponse with message := lvl.introduction}
|
||||
let levelInfo : LevelInfo :=
|
||||
{ index := lvl.index,
|
||||
title := lvl.title,
|
||||
tactics := lvl.tactics,
|
||||
lemmas := lvl.lemmas,
|
||||
errors := resp.errors,
|
||||
goals := resp.goals,
|
||||
message := resp.message }
|
||||
output (← levelInfo.toJson)
|
||||
mainLoop
|
||||
levelM.run lvl |>.run' state
|
||||
let metaM : MetaM Unit := termElabM.run' (ctx := {})
|
||||
try
|
||||
let env ← importModules [{ module := `Init : Import }, { module := GameName ++ "Levels" ++ levelName : Import }] {} 0
|
||||
discard <| metaM.run'.toIO coreCtx { env := env }
|
||||
catch
|
||||
| .userError s => output s!"Could not run level {idx}: {s}"
|
||||
| _ => output s!"Could not run level {idx}"
|
||||
|
||||
where
|
||||
|
||||
mkResponse (errors : Array String := #[]) : LevelM Response := do
|
||||
let savedState ← getState
|
||||
let goals := savedState.tacticState.tactic.goals
|
||||
return { goals := (← liftM $ goals.mapM Lean.MVarId.toGameGoal), message := savedState.message, errors := errors }
|
||||
|
||||
/-- Try to parse the given String as a single line tactic invocation. Update the LevelM state only
|
||||
if the tactic succeeds. Always return a Response object which contains information about the current
|
||||
state with a message and errors if any. -/
|
||||
runTactic (tacticString : String) : LevelM Response := do
|
||||
let lvl ← read
|
||||
let tacticNames := (lvl.tactics.map (·.name.toString)).toList
|
||||
let tacName := (tacticString.trim.splitOn " ").headD ""
|
||||
if not (tacticNames.contains tacName) then mkResponse #["Unrecognized tactic"] else
|
||||
let savedState ← getState
|
||||
match Parser.runParserCategory (← getEnv) `tactic tacticString "<stdin>" with
|
||||
| Except.error err => mkResponse #[err]
|
||||
| Except.ok stx => do
|
||||
savedState.tacticState.term.restore
|
||||
let mvarId : MVarId := savedState.tacticState.tactic.goals.head!
|
||||
try
|
||||
let unsolvedGoals ← Tactic.run mvarId do set savedState.tacticState.tactic
|
||||
evalTactic stx
|
||||
if (← getThe Core.State).messages.hasErrors then
|
||||
let messages := (← getThe Core.State).messages.getErrorMessages.toList.toArray
|
||||
mkResponse (← (messages.map Message.data).mapM fun md => md.toString)
|
||||
else
|
||||
let savedState : Tactic.SavedState := { term := (← Term.saveState), tactic := { goals := unsolvedGoals}}
|
||||
let mut message := ""
|
||||
match unsolvedGoals with
|
||||
| goal::_ => do
|
||||
let normalized_tgt ← normalizedRevertExpr goal
|
||||
for msg in lvl.messages do
|
||||
if ← isDefEq normalized_tgt msg.normalized_goal then
|
||||
message := msg.message
|
||||
break
|
||||
| [] => pure ()
|
||||
if unsolvedGoals matches [] then
|
||||
message := (← read).conclusion
|
||||
modify fun s => s.push {tacticState := savedState, message := message}
|
||||
mkResponse
|
||||
catch ex => mkResponse #[← ex.toMessageData.toString]
|
||||
|
||||
mainLoop : LevelM Unit := do
|
||||
match ← Action.get with
|
||||
| Action.runTactic tac => do let resp ← runTactic tac; output s!"{← resp.toJson}"
|
||||
| Action.loadLevel n => runLevel GameName levels n
|
||||
| Action.undo => do modify fun s => s.pop; output s!"{← (← mkResponse).toJson}"
|
||||
| Action.restartLevel => runLevel GameName levels idx
|
||||
| Action.prev => runLevel GameName levels idx.pred
|
||||
| Action.next => runLevel GameName levels idx.succ
|
||||
| Action.quit => IO.Process.exit 0
|
||||
| Action.restartGame => output "Can't restart game now"
|
||||
| Action.info => output "Can't get info now"
|
||||
| Action.invalid s => output s!"{← { ← mkResponse with errors := #[s!"Invalid action: {s}"] : Response}.toJson}"
|
||||
mainLoop
|
||||
|
||||
|
||||
open System Lean Std in
|
||||
partial def runGame (GameName : Name) (paths : List FilePath): IO Unit := do
|
||||
searchPathRef.set paths
|
||||
let env ← importModules [{ module := `Init : Import }, { module := GameName : Import }] {} 0
|
||||
let termElabM : TermElabM Unit := do
|
||||
let levels := levelsExt.getState env
|
||||
let game := {← gameExt.get with nb_levels := levels.size }
|
||||
mainLoop game levels
|
||||
let metaM : MetaM Unit := termElabM.run' (ctx := {})
|
||||
discard <| metaM.run'.toIO coreCtx { env := env }
|
||||
where
|
||||
mainLoop (game : Game) (levels : HashMap Nat GameLevel): IO Unit := do
|
||||
match ← Action.get with
|
||||
| Action.info => output (toJson game)
|
||||
| Action.loadLevel n => runLevel GameName levels n
|
||||
| Action.quit => IO.Process.exit 0
|
||||
| Action.invalid s => output s!"Invalid action: {s}"
|
||||
| _ => output "Invalid action"
|
||||
mainLoop game levels
|
||||
|
||||
end Server
|
||||
@@ -0,0 +1,26 @@
|
||||
import Lean
|
||||
|
||||
open Lean
|
||||
|
||||
/-- A persistent environment extension that is meant to hold a single (mutable) value. -/
|
||||
def SingleValPersistentEnvExtension (α : Type) := PersistentEnvExtension α α α
|
||||
|
||||
instance {α} [Inhabited α] : Inhabited (SingleValPersistentEnvExtension α) :=
|
||||
inferInstanceAs <| Inhabited <| PersistentEnvExtension α α α
|
||||
|
||||
def registerSingleValPersistentEnvExtension (name : Name) (α : Type) [Inhabited α] : IO (SingleValPersistentEnvExtension α) :=
|
||||
registerPersistentEnvExtension {
|
||||
name := name,
|
||||
mkInitial := pure default,
|
||||
addImportedFn := mkStateFromImportedEntries (fun _ b => return b) (return default),
|
||||
addEntryFn := (λ _ b => b),
|
||||
exportEntriesFn := λ x => #[x]
|
||||
}
|
||||
|
||||
variable {m: Type → Type} [Monad m] [MonadEnv m] {α : Type} [Inhabited α]
|
||||
|
||||
def SingleValPersistentEnvExtension.get (ext : SingleValPersistentEnvExtension α) : m α :=
|
||||
return ext.getState (← getEnv)
|
||||
|
||||
def SingleValPersistentEnvExtension.set (ext : SingleValPersistentEnvExtension α) (a : α) : m Unit := do
|
||||
modifyEnv (ext.modifyState · (λ _ => a))
|
||||
@@ -0,0 +1,30 @@
|
||||
import Lean
|
||||
|
||||
open Lean
|
||||
|
||||
def Lean.Expr.getFVars (e : Expr) : Array FVarId :=
|
||||
(Lean.collectFVars {} e).fvarIds
|
||||
|
||||
|
||||
/-- Returns the type of the goal after reverting all free variables in the order
|
||||
where they appear in the goal type. -/
|
||||
partial def normalizedRevertExpr (goal : MVarId) : MetaM Expr := do
|
||||
goal.withContext do
|
||||
let (_, new) ← goal.revert (← goal.getType).getFVars true
|
||||
let e ← new.getType
|
||||
if e.hasFVar then
|
||||
return ← normalizedRevertExpr new
|
||||
else
|
||||
return (← new.getType)
|
||||
|
||||
|
||||
def Lean.MessageLog.getErrorMessages (log : MessageLog) : MessageLog :=
|
||||
{ msgs := log.msgs.filter (·.severity matches .error) }
|
||||
|
||||
/-- A version of `println!` that actually does its job by flushing stdout. -/
|
||||
def output {α : Type} [ToString α] (s : α) : IO Unit := do
|
||||
println! s
|
||||
IO.FS.Stream.flush (← IO.getStdout)
|
||||
|
||||
def Lean.LocalDecl.toJson (decl : LocalDecl) : MetaM Json :=
|
||||
return Lean.ToJson.toJson [toString decl.userName, toString (← Meta.ppExpr decl.type)]
|
||||
Reference in New Issue
Block a user