module Game.LambdaHack.BindingAction
( stdBinding
) where
import Control.Monad.State hiding (State, state)
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Char as Char
import Game.LambdaHack.Action
import Game.LambdaHack.State
import qualified Game.LambdaHack.Config as Config
import Game.LambdaHack.Level
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Actions
import Game.LambdaHack.Running
import Game.LambdaHack.EffectAction
import Game.LambdaHack.Binding
import qualified Game.LambdaHack.Key as K
import Game.LambdaHack.ActorState
import Game.LambdaHack.Command
configCmd :: Config.CP -> [(K.Key, Cmd)]
configCmd config =
let section = Config.getItems config "commands"
mkKey s =
case K.keyTranslate s of
K.Unknown _ -> assert `failure` ("unknown command key " ++ s)
key -> key
mkCmd s = read s :: Cmd
mkCommand (key, def) = (mkKey key, mkCmd def)
in L.map mkCommand section
semanticsCmd :: [(K.Key, Cmd)]
-> (Cmd -> ActionFrame ())
-> (Cmd -> String)
-> [((K.Key, K.Modifier), (String, Bool, ActionFrame ()))]
semanticsCmd cmdList cmdS cmdD =
let mkDescribed cmd =
let semantics = if timedCmd cmd
then checkCursor $ cmdS cmd
else cmdS cmd
in (cmdD cmd, timedCmd cmd, semantics)
mkCommand (key, def) = ((key, K.NoModifier), mkDescribed def)
in L.map mkCommand cmdList
checkCursor :: ActionFrame () -> ActionFrame ()
checkCursor h = do
cursor <- gets scursor
slid <- gets slid
if creturnLn cursor == slid
then h
else abortWith "this command does not work on remote levels"
heroSelection :: [((K.Key, K.Modifier), (String, Bool, ActionFrame ()))]
heroSelection =
let select k = do
s <- get
case tryFindHeroK s k of
Nothing -> abortWith "No such member of the party."
Just aid -> selectPlayer aid >> returnNoFrame ()
heroSelect k = ( (K.Char (Char.intToDigit k), K.NoModifier)
, ("", False, select k)
)
in fmap heroSelect [0..9]
stdBinding :: Config.CP
-> (Cmd -> ActionFrame ())
-> (Cmd -> String)
-> Binding (ActionFrame ())
stdBinding config cmdS cmdD =
let section = Config.getItems config "macros"
!kmacro = macroKey section
cmdList = configCmd config
semList = semanticsCmd cmdList cmdS cmdD
moveWidth f = do
lxsize <- gets (lxsize . slevel)
move $ f lxsize
runWidth f = do
lxsize <- gets (lxsize . slevel)
run (f lxsize, 0)
cmdDir = K.moveBinding moveWidth runWidth
in Binding
{ kcmd = M.fromList $
cmdDir ++
heroSelection ++
semList ++
[
((K.Char 'r', K.Control), ("", False, modify cycleMarkVision
>> returnNoFrame ())),
((K.Char 'o', K.Control), ("", False, modify toggleOmniscient
>> returnNoFrame ())),
((K.Char 'i', K.Control), ("", False, gets (lmeta . slevel)
>>= abortWith))
]
, kmacro
, kmajor = L.map fst $ L.filter (majorCmd . snd) cmdList
, kdir = L.map fst cmdDir
}