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.Actor
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 -> Action ())
-> (Cmd -> String)
-> [(K.Key, (String, Action ()))]
semanticsCmd cmdList cmdS cmdD =
let mkDescribed cmd =
let semantics = if timedCmd cmd
then checkCursor $ cmdS cmd
else cmdS cmd
in (cmdD cmd, semantics)
mkCommand (key, def) = (key, mkDescribed def)
in L.map mkCommand cmdList
checkCursor :: Action () -> Action ()
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, (String, Action ()))]
heroSelection =
let heroSelect k = (K.Char (Char.intToDigit k),
("", void $ selectPlayer $ AHero k))
in fmap heroSelect [0..9]
stdBinding :: Config.CP
-> (Cmd -> Action ())
-> (Cmd -> String)
-> Binding (Action ())
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)
in Binding
{ kcmd = M.fromList $
K.moveBinding moveWidth runWidth ++
heroSelection ++
semList ++
[
(K.Char 'R', ("", modify cycleMarkVision)),
(K.Char 'O', ("", modify toggleOmniscient)),
(K.Char 'I', ("", gets (lmeta . slevel) >>= abortWith))
]
, kmacro
, kmajor = L.map fst $ L.filter (majorCmd . snd) cmdList
, ktimed = L.map fst $ L.filter (timedCmd . snd) cmdList
}