diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 --- a/.travis.yml +++ /dev/null @@ -1,10 +0,0 @@ -language: haskell - -install: - - cabal install gtk2hs-buildtools - - cabal install -f-vty -f-curses --only-dependencies - - cabal install -fvty -f-curses --only-dependencies - - cabal install -f-vty -fcurses --only-dependencies - -script: - - cabal install -f-vty -f-curses && (make test-travis || (cat ~/.LambdaHack/config.rules.dump ; tail -n 200 /tmp/stdtest.log ; exit 77)) && cabal install -fvty -f-curses && (make test-travis || (cat ~/.LambdaHack/config.rules.dump ; tail -n 200 /tmp/stdtest.log ; exit 77)) && cabal install -f-vty -fcurses && (make test-travis || (cat ~/.LambdaHack/config.rules.dump ; tail -n 200 /tmp/stdtest.log ; exit 77)) diff --git a/Game/LambdaHack/Client.hs b/Game/LambdaHack/Client.hs --- a/Game/LambdaHack/Client.hs +++ b/Game/LambdaHack/Client.hs @@ -3,11 +3,11 @@ -- See -- . module Game.LambdaHack.Client - ( cmdClientAISem, cmdClientUISem - , loopAI, loopUI, exeFrontend + ( cmdClientAISem, cmdClientUISem, exeFrontend , MonadClient, MonadClientUI, MonadClientReadServer, MonadClientWriteServer ) where +import Control.Exception.Assert.Sugar import Control.Monad import Data.Maybe @@ -27,21 +27,21 @@ import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State +import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Frontend -import Control.Exception.Assert.Sugar storeUndo :: MonadClient m => Atomic -> m () storeUndo _atomic = maybe skip (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli}) $ Nothing -- TODO: undoAtomic atomic -cmdClientAISem :: (MonadAtomic m, MonadClientWriteServer CmdSerTakeTime m) +cmdClientAISem :: (MonadAtomic m, MonadClientWriteServer CmdTakeTimeSer m) => CmdClientAI -> m () cmdClientAISem cmd = case cmd of CmdAtomicAI cmdA -> do cmds <- cmdAtomicFilterCli cmdA - mapM_ cmdAtomicSemCli cmds - mapM_ execCmdAtomic cmds + mapM_ (\c -> cmdAtomicSemCli c + >> execCmdAtomic c) cmds mapM_ (storeUndo . CmdAtomic) cmds CmdQueryAI aid -> do cmdC <- queryAI aid @@ -49,15 +49,15 @@ CmdPingAI -> writeServer $ WaitSer $ toEnum (-1) -cmdClientUISem :: ( MonadAtomic m, MonadClientAbort m - , MonadClientUI m, MonadClientWriteServer CmdSer m ) +cmdClientUISem :: ( MonadAtomic m, MonadClientUI m + , MonadClientWriteServer CmdSer m ) => CmdClientUI -> m () cmdClientUISem cmd = case cmd of CmdAtomicUI cmdA -> do cmds <- cmdAtomicFilterCli cmdA - mapM_ cmdAtomicSemCli cmds - mapM_ execCmdAtomic cmds - mapM_ (drawCmdAtomicUI False) cmds + mapM_ (\c -> cmdAtomicSemCli c + >> execCmdAtomic c + >> drawCmdAtomicUI False c) cmds mapM_ (storeUndo . CmdAtomic) cmds -- TODO: only store cmdA? SfxAtomicUI sfx -> do drawSfxAtomicUI False sfx @@ -72,28 +72,28 @@ snoMore <- getsClient $ snoMore . sdebugCli when snoMore $ void $ displayMore ColorFull "Flushing frames." -- Return the ping. - writeServer $ TakeTimeSer $ WaitSer $ toEnum (-1) + writeServer $ CmdTakeTimeSer $ WaitSer $ toEnum (-1) -- | Wire together game content, the main loop of game clients, -- the main game loop assigned to this frontend (possibly containing -- the server loop, if the whole game runs in one process), -- UI config and the definitions of game commands. -exeFrontend :: ( MonadAtomic m, MonadClientAbort m, MonadClientUI m +exeFrontend :: ( MonadAtomic m, MonadClientUI m , MonadClientReadServer CmdClientUI m , MonadClientWriteServer CmdSer m , MonadAtomic n , MonadClientReadServer CmdClientAI n - , MonadClientWriteServer CmdSerTakeTime n ) + , MonadClientWriteServer CmdTakeTimeSer n ) => (m () -> SessionUI -> State -> StateClient -> ChanServer CmdClientUI CmdSer -> IO ()) -> (n () -> SessionUI -> State -> StateClient - -> ChanServer CmdClientAI CmdSerTakeTime + -> ChanServer CmdClientAI CmdTakeTimeSer -> IO ()) -> Kind.COps -> DebugModeCli -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer -> IO ()) - -> (FactionId -> ChanServer CmdClientAI CmdSerTakeTime + -> (FactionId -> ChanServer CmdClientAI CmdTakeTimeSer -> IO ()) -> IO ()) -> IO () @@ -101,7 +101,8 @@ cops@Kind.COps{corule} sdebugCli exeServer = do -- UI config reloaded at each client start. sconfigUI <- mkConfigUI corule - let !sbinding = stdBinding sconfigUI -- evaluate to check for errors + let stdRuleset = Kind.stdRuleset corule + !sbinding = stdBinding corule sconfigUI -- evaluate to check for errors sdebugMode = (\dbg -> dbg {sfont = sfont dbg `mplus` Just (configFont sconfigUI)}) . @@ -110,7 +111,7 @@ (\dbg -> dbg {snoAnim = snoAnim dbg `mplus` Just (configNoAnim sconfigUI)}) . (\dbg -> dbg {ssavePrefixCli = - ssavePrefixCli dbg `mplus` Just (configSavePrefix sconfigUI)}) + ssavePrefixCli dbg `mplus` Just (rsavePrefix stdRuleset)}) $ sdebugCli defHist <- defHistory let exeClientUI = executorUI $ loopUI sdebugMode cmdClientUISem diff --git a/Game/LambdaHack/Client/Action.hs b/Game/LambdaHack/Client/Action.hs --- a/Game/LambdaHack/Client/Action.hs +++ b/Game/LambdaHack/Client/Action.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} -- | Game action monads and basic building blocks for human and computer -- player actions. Has no access to the the main action type. -- Does not export the @liftIO@ operation nor a few other implementation @@ -7,12 +8,7 @@ MonadClient( getClient, getsClient, putClient, modifyClient, saveClient ) , MonadClientUI , MonadClientReadServer(..), MonadClientWriteServer(..) - , MonadClientAbort( abortWith, tryWith ) , SessionUI(..), ConnFrontend(..), connFrontend - -- * Various ways to abort action - , abort, abortIfWith, neverMind - -- * Abort exception handlers - , tryRepeatedlyWith, tryIgnore, tryWithSlide -- * Executing actions , mkConfigUI -- * Accessors to the game session Reader and the Perception Reader(-like) @@ -20,63 +16,83 @@ -- * History and report , msgAdd, msgReset, recordHistory -- * Key input - , getKeyOverlayCommand, getInitConfirms + , getKeyOverlayCommand, getInitConfirms, stopPlayBack, stopRunning -- * Display and key input , displayFrames, displayMore, displayYesNo, displayChoiceUI -- * Generate slideshows - , promptToSlideshow, overlayToSlideshow + , promptToSlideshow, overlayToSlideshow, overlayToBlankSlideshow -- * Draw frames , drawOverlay, animate -- * Assorted primitives , restoreGame, removeServerSave, displayPush, scoreToSlideshow - , rndToAction, getArenaUI, getLeaderUI - , targetToPos, partAidLeader, partActorLeader + , rndToAction, getArenaUI, getLeaderUI, targetDescLeader, viewedLevel + , aidTgtToPos, aidTgtAims, leaderTgtToPos, leaderTgtAims, cursorToPos + , partAidLeader, partActorLeader, unexploredDepth + , getCacheBfsAndPath, getCacheBfs, accessCacheBfs, actorAimsPos + , closestUnknown, closestSmell, furthestKnown, closestTriggers + , closestItems, closestFoes, actorAbilities , debugPrint ) where +import Control.Arrow ((&&&)) import Control.Concurrent import Control.Concurrent.STM import Control.DeepSeq import Control.Exception.Assert.Sugar import Control.Monad import qualified Control.Monad.State as St -import Control.Monad.Writer.Strict (WriterT, lift, tell) import qualified Data.EnumMap.Strict as EM +import qualified Data.EnumSet as ES +import qualified Data.Ini as Ini +import qualified Data.Ini.Reader as Ini +import qualified Data.Ini.Types as Ini +import Data.List import qualified Data.Map.Strict as M import Data.Maybe -import qualified Data.Monoid as Monoid +import Data.Monoid +import Data.Ord import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU import System.Directory import System.FilePath import System.Time +import Text.Read import Game.LambdaHack.Client.Action.ActionClass import Game.LambdaHack.Client.Binding import Game.LambdaHack.Client.Config import Game.LambdaHack.Client.Draw -import Game.LambdaHack.Client.HumanCmd import Game.LambdaHack.Client.State +import Game.LambdaHack.Common.Ability (Ability) import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Animation -import qualified Game.LambdaHack.Common.ConfigIO as ConfigIO +import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.HighScore as HighScore +import Game.LambdaHack.Common.HumanCmd import qualified Game.LambdaHack.Common.Key as K import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point +import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State +import qualified Game.LambdaHack.Common.Tile as Tile +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.ActorKind +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind +import Game.LambdaHack.Content.TileKind import qualified Game.LambdaHack.Frontend as Frontend +import Game.LambdaHack.Utils.File debugPrint :: MonadClient m => Text -> m () debugPrint t = do @@ -92,45 +108,6 @@ liftIO $ atomically $ writeTQueue toF (fid, efr) } --- | Reset the state and resume from the last backup point, i.e., invoke --- the failure continuation. -abort :: MonadClientAbort m => m a -abort = abortWith "" - --- | Abort and print the given msg if the condition is true. -abortIfWith :: MonadClientAbort m => Bool -> Msg -> m a -abortIfWith True msg = abortWith msg -abortIfWith False _ = abortWith "" - --- | Abort and conditionally print the fixed message. -neverMind :: MonadClientAbort m => Bool -> m a -neverMind b = abortIfWith b "never mind" - --- | Take a handler and a computation. If the computation fails, the --- handler is invoked and then the computation is retried. -tryRepeatedlyWith :: MonadClientAbort m => (Msg -> m ()) -> m () -> m () -tryRepeatedlyWith exc m = - tryWith (\msg -> exc msg >> tryRepeatedlyWith exc m) m - --- | Try the given computation and silently catch failure. -tryIgnore :: MonadClientAbort m => m () -> m () -tryIgnore = - tryWith (\msg -> unless (T.null msg) - $ assert `failure` "can't catch failure with message" - `twith` msg) - --- | Set the current exception handler. Apart of executing it, --- draw and pass along a slide with the abort message (even if message empty). -tryWithSlide :: (MonadClientAbort m, MonadClientUI m) - => m a -> WriterT Slideshow m a -> WriterT Slideshow m a -tryWithSlide exc h = - let excMsg msg = do - msgReset "" - slides <- promptToSlideshow msg - tell slides - lift exc - in tryWith excMsg h - displayFrame :: MonadClientUI m => Bool -> Maybe SingleFrame -> m () displayFrame isRunning mf = do ConnFrontend{writeConnFrontend} <- getsSession sfconn @@ -142,16 +119,54 @@ promptGetKey :: MonadClientUI m => [K.KM] -> SingleFrame -> m K.KM promptGetKey frontKM frontFr = do - ConnFrontend{..} <- getsSession sfconn - writeConnFrontend Frontend.FrontKey {..} - readConnFrontend + lastPlayOld <- getsClient slastPlay + km <- case lastPlayOld of + km : kms | null frontKM || km `elem` frontKM -> do + displayFrame False $ Just frontFr + modifyClient $ \cli -> cli {slastPlay = kms} + return km + _ -> do + unless (null lastPlayOld) stopPlayBack -- something went wrong + ConnFrontend{..} <- getsSession sfconn + writeConnFrontend Frontend.FrontKey {..} + readConnFrontend + (seqCurrent, seqPrevious, k) <- getsClient slastRecord + let slastRecord = (km : seqCurrent, seqPrevious, k) + modifyClient $ \cli -> cli {slastRecord} + return km +stopPlayBack :: MonadClientUI m => m () +stopPlayBack = do + modifyClient $ \cli -> cli + { slastPlay = [] + , slastRecord = let (seqCurrent, seqPrevious, _) = slastRecord cli + in (seqCurrent, seqPrevious, 0) + , swaitTimes = - swaitTimes cli + } + stopRunning + +stopRunning :: MonadClientUI m => m () +stopRunning = do + srunning <- getsClient srunning + case srunning of + Nothing -> return () + Just RunParams{runLeader} -> do + -- Switch to the original leader, from before the run start, unless dead. + side <- getsClient sside + fact <- getsState $ (EM.! side) . sfactionD + arena <- getArenaUI + s <- getState + when (memActor runLeader arena s && not (isSpawnFact fact)) $ + modifyClient $ updateLeader runLeader s + modifyClient (\cli -> cli { srunning = Nothing }) + -- | Display a slideshow, awaiting confirmation for each slide except the last. getInitConfirms :: MonadClientUI m => ColorMode -> [K.KM] -> Slideshow -> m Bool getInitConfirms dm frontClear slides = do ConnFrontend{..} <- getsSession sfconn - frontSlides <- mapM (drawOverlay dm) $ runSlideshow slides + let (onBlank, ovs) = slideshow slides + frontSlides <- mapM (drawOverlay onBlank dm) ovs -- The first two cases are optimizations: case frontSlides of [] -> return True @@ -163,52 +178,6 @@ km <- readConnFrontend return $! km /= K.escKey -getLeaderUI :: MonadClientUI m => m ActorId -getLeaderUI = do - cli <- getClient - case _sleader cli of - Nothing -> assert `failure` "leader expected but not found" `twith` cli - Just leader -> return leader - -getArenaUI :: MonadClientUI m => m LevelId -getArenaUI = do - mleader <- getsClient _sleader - case mleader of - Just leader -> getsState $ blid . getActorBody leader - Nothing -> do - side <- getsClient sside - factionD <- getsState sfactionD - let fact = factionD EM.! side - case gquit fact of - Just Status{stDepth} -> return $ toEnum stDepth - Nothing -> do - dungeon <- getsState sdungeon - let (minD, maxD) = - case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of - (Just ((s, _), _), Just ((e, _), _)) -> (s, e) - _ -> assert `failure` "empty dungeon" `twith` dungeon - return $ max minD $ min maxD $ playerEntry $ gplayer fact - --- | Calculate the position of leader's target. -targetToPos :: MonadClientUI m => m (Maybe Point) -targetToPos = do - mleader <- getsClient _sleader - case mleader of - Nothing -> return Nothing - Just leader -> do - scursor <- getsClient scursor - lid <- getsState $ blid . getActorBody leader - target <- getsClient $ getTarget leader - case target of - Just (TPos pos) -> return $ Just pos - Just (TEnemy a _ll) -> do - mem <- getsState $ memActor a lid -- alive and visible? - if mem then do - pos <- getsState $ bpos . getActorBody a - return $ Just pos - else return Nothing - Nothing -> return scursor - -- | Get the key binding. askBinding :: MonadClientUI m => m Binding askBinding = getsSession sbinding @@ -240,14 +209,12 @@ $ EM.lookup lid fper -- | Display an overlay and wait for a human player command. -getKeyOverlayCommand :: MonadClientUI m => Overlay -> m K.KM -getKeyOverlayCommand overlay = do - frame <- drawOverlay ColorFull overlay - keyb <- askBinding +getKeyOverlayCommand :: MonadClientUI m => Bool -> Overlay -> m K.KM +getKeyOverlayCommand onBlank overlay = do + frame <- drawOverlay onBlank ColorFull overlay -- Give the previous client time to display his frames. liftIO $ threadDelay 1000 - km <- promptGetKey [] frame - return $! fromMaybe km $ M.lookup km $ kmacro keyb + promptGetKey [] frame -- | Push frames or delays to the frame queue. displayFrames :: MonadClientUI m => Frames -> m () @@ -271,42 +238,42 @@ displayMore dm prompt = do slides <- promptToSlideshow $ prompt <+> moreMsg -- Two frames drawn total (unless 'prompt' very long). - getInitConfirms dm [] $ slides Monoid.<> toSlideshow [[]] + getInitConfirms dm [] $ slides <> toSlideshow False [[]] -- | Print a yes/no question and return the player's answer. Use black -- and white colours to turn player's attention to the choice. displayYesNo :: MonadClientUI m => ColorMode -> Msg -> m Bool displayYesNo dm prompt = do sli <- promptToSlideshow $ prompt <+> yesnoMsg - frame <- drawOverlay dm $ head $ runSlideshow sli + frame <- drawOverlay False dm $ head . snd $ slideshow sli getYesNo frame -- TODO: generalize getInitConfirms and displayChoiceUI to a single op -- | Print a prompt and an overlay and wait for a player keypress. -- If many overlays, scroll screenfuls with SPACE. Do not wrap screenfuls -- (in some menus @?@ cycles views, so the user can restart from the top). -displayChoiceUI :: (MonadClientAbort m, MonadClientUI m) - => Msg -> Overlay -> [K.KM] -> m K.KM +displayChoiceUI :: MonadClientUI m + => Msg -> Overlay -> [K.KM] -> m (Either Slideshow K.KM) displayChoiceUI prompt ov keys = do - slides <- fmap runSlideshow $ overlayToSlideshow (prompt <> ", ESC]") ov + (_, ovs) <- fmap slideshow $ overlayToSlideshow (prompt <> ", ESC]") ov let legalKeys = [ K.KM {key=K.Space, modifier=K.NoModifier} , K.escKey ] ++ keys - loop [] = neverMind True + loop [] = fmap Left $ promptToSlideshow "never mind" loop (x : xs) = do - frame <- drawOverlay ColorFull x + frame <- drawOverlay False ColorFull x km@K.KM {..} <- promptGetKey legalKeys frame case key of - K.Esc -> neverMind True + K.Esc -> fmap Left $ promptToSlideshow "never mind" K.Space -> loop xs - _ -> return km - loop slides + _ -> return $ Right km + loop ovs -- | The prompt is shown after the current message, but not added to history. -- This is useful, e.g., in targeting mode, not to spam history. promptToSlideshow :: MonadClientUI m => Msg -> m Slideshow -promptToSlideshow prompt = overlayToSlideshow prompt [] +promptToSlideshow prompt = overlayToSlideshow prompt emptyOverlay -- | The prompt is shown after the current message at the top of each slide. -- Together they may take more than one line. The prompt is not added @@ -315,23 +282,35 @@ overlayToSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow overlayToSlideshow prompt overlay = do lid <- getArenaUI - Level{lysize} <- getLevel lid -- TODO: screen length or viewLevel + Level{lxsize, lysize} <- getLevel lid -- TODO: screen length or viewLevel sreport <- getsClient sreport - let msg = splitReport (addMsg sreport prompt) - return $! splitOverlay lysize msg overlay + let msg = splitReport lxsize (addMsg sreport prompt) + return $! splitOverlay False (lysize + 1) msg overlay +overlayToBlankSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow +overlayToBlankSlideshow prompt overlay = do + lid <- getArenaUI + Level{lysize} <- getLevel lid -- TODO: screen length or viewLevel + return $! splitOverlay True (lysize + 3) (toOverlay [prompt]) overlay + -- | Draw the current level with the overlay on top. -drawOverlay :: MonadClientUI m => ColorMode -> Overlay -> m SingleFrame -drawOverlay dm over = do +drawOverlay :: MonadClientUI m => Bool -> ColorMode -> Overlay -> m SingleFrame +drawOverlay onBlank dm over = do cops <- getsState scops - stgtMode <- getsClient stgtMode - arena <- getArenaUI - let lid = maybe arena tgtLevelId stgtMode + lid <- viewedLevel mleader <- getsClient _sleader s <- getState cli <- getClient per <- getPerFid lid - return $! draw dm cops per lid mleader cli s over + tgtPos <- leaderTgtToPos + cursorPos <- cursorToPos + let pathFromLeader leader = + maybe (return Nothing) (fmap Just . getCacheBfsAndPath leader) tgtPos + bfsmpath <- maybe (return Nothing) pathFromLeader mleader + tgtDesc <- maybe (return "------") targetDescLeader mleader + cursorDesc <- targetDescCursor + return $! draw onBlank dm cops per lid mleader cursorPos tgtPos + bfsmpath cli s cursorDesc tgtDesc over -- TODO: if more slides, don't take head, but do as in getInitConfirms, -- but then we have to clear the messages or they get redisplayed @@ -341,8 +320,8 @@ displayPush :: MonadClientUI m => m () displayPush = do sls <- promptToSlideshow "" - let slide = head $ runSlideshow sls - frame <- drawOverlay ColorFull slide + let slide = head . snd $ slideshow sls + frame <- drawOverlay False ColorFull slide -- Visually speed up (by remving all empty frames) the show of the sequence -- of the move frames if the player is running. srunning <- getsClient srunning @@ -350,36 +329,43 @@ scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow scoreToSlideshow total status = do + fid <- getsClient sside + fact <- getsState $ (EM.! fid) . sfactionD table <- getsState shigh time <- getsState stime date <- liftIO getClockTime - let showScore (ntable, pos) = HighScore.slideshow ntable pos status - return $! maybe Monoid.mempty showScore - $ HighScore.register table total time status date + scurDifficulty <- getsClient scurDifficulty + let showScore (ntable, pos) = HighScore.highSlideshow ntable pos status + diff | not $ playerUI $ gplayer fact = 0 + | otherwise = scurDifficulty + return $! maybe mempty showScore + $ HighScore.register table total time status date diff restoreGame :: MonadClient m => m (Maybe (State, StateClient)) restoreGame = do Kind.COps{corule} <- getsState scops - let pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule + let stdRuleset = Kind.stdRuleset corule + pathsDataFile = rpathsDataFile stdRuleset + cfgUIName = rcfgUIName stdRuleset side <- getsClient sside isAI <- getsClient sisAI prefix <- getsClient $ ssavePrefixCli . sdebugCli - ConfigUI{ configAppDataDir - , configUICfgFile } <- getsClient sconfigUI - let copies = [(configUICfgFile <.> ".default", configUICfgFile <.> ".ini")] + let copies = [( "GameDefinition" cfgUIName <.> "default" + , cfgUIName <.> "ini" )] name = fromMaybe "save" prefix <.> saveName side isAI - liftIO $ Save.restoreGame name configAppDataDir copies pathsDataFile + liftIO $ Save.restoreGame name copies pathsDataFile -- | Assuming the client runs on the same machine and for the same -- user as the server, move the server savegame out of the way. removeServerSave :: MonadClient m => m () removeServerSave = do prefix <- getsClient $ ssavePrefixCli . sdebugCli -- hack: assume the same - ConfigUI{configAppDataDir} <- getsClient sconfigUI - let serverSaveFile = configAppDataDir + dataDir <- liftIO appDataDir + let serverSaveFile = dataDir fromMaybe "save" prefix <.> serverSaveName - liftIO $ renameFile serverSaveFile (serverSaveFile ++ ".bkp") + bSer <- liftIO $ doesFileExist serverSaveFile + when bSer $ liftIO $ renameFile serverSaveFile (serverSaveFile <.> "bkp") -- | Invoke pseudo-random computation with the generator kept in the state. rndToAction :: MonadClient m => Rnd a -> m a @@ -400,13 +386,22 @@ cli <- getClient s <- getState per <- getPerFid arena + tgtPos <- leaderTgtToPos + cursorPos <- cursorToPos + let pathFromLeader leader = + maybe (return Nothing) (fmap Just . getCacheBfsAndPath leader) tgtPos + bfsmpath <- maybe (return Nothing) pathFromLeader mleader + tgtDesc <- maybe (return "------") targetDescLeader mleader + cursorDesc <- targetDescCursor let over = renderReport sreport - topLineOnly = truncateMsg lxsize over - basicFrame = draw ColorFull cops per arena mleader cli s [topLineOnly] + topLineOnly = truncateToOverlay lxsize over + basicFrame = + draw False ColorFull cops per arena mleader + cursorPos tgtPos bfsmpath cli s cursorDesc tgtDesc topLineOnly snoAnim <- getsClient $ snoAnim . sdebugCli - return $ if fromMaybe False snoAnim - then [Just basicFrame] - else renderAnim lxsize lysize basicFrame anim + return $! if fromMaybe False snoAnim + then [Just basicFrame] + else renderAnim lxsize lysize basicFrame anim -- | The part of speech describing the actor or a special name if a leader -- of the observer's faction. The actor may not be present in the dungeon. @@ -425,43 +420,468 @@ b <- getsState $ getActorBody aid partActorLeader aid b -parseConfigUI :: FilePath -> ConfigIO.CP -> ConfigUI -parseConfigUI dataDir cp = - let mkKey s = - case K.keyTranslate s of - K.Unknown _ -> - assert `failure` "unknown config file key" `twith` (s, cp) - key -> key - mkKM ('C':'T':'R':'L':'-':s) = K.KM {key=mkKey s, modifier=K.Control} - mkKM s = K.KM {key=mkKey s, modifier=K.NoModifier} - configCommands = - let mkCommand (key, def) = (mkKM key, read def :: HumanCmd) - section = ConfigIO.getItems cp "commands" +parseConfigUI :: Ini.Config -> ConfigUI +parseConfigUI cfg = + let configCommands = + let mkCommand (ident, keydef) = + case stripPrefix "Macro_" ident of + Just _ -> + let (key, def) = read keydef + in (K.mkKM key, def :: (CmdCategory, HumanCmd)) + Nothing -> assert `failure` "wrong macro id" `twith` ident + section = Ini.allItems "extra_commands" cfg in map mkCommand section - configAppDataDir = dataDir - configUICfgFile = "config.ui" - configSavePrefix = ConfigIO.get cp "file" "savePrefix" - configMacros = - let trMacro (from, to) = - let fromTr = mkKM from - toTr = mkKM to - in if fromTr == toTr - then assert `failure` "degenerate alias" `twith` toTr - else (fromTr, toTr) - section = ConfigIO.getItems cp "macros" - in map trMacro section - configFont = ConfigIO.get cp "ui" "font" - configHistoryMax = ConfigIO.get cp "ui" "historyMax" - configMaxFps = ConfigIO.get cp "ui" "maxFps" - configNoAnim = ConfigIO.get cp "ui" "noAnim" + configHeroNames = + let toNumber (ident, name) = + case stripPrefix "HeroName_" ident of + Just n -> (read n, T.pack name) + Nothing -> assert `failure` "wrong hero name id" `twith` ident + section = Ini.allItems "hero_names" cfg + in map toNumber section + getOption :: forall a. Read a => String -> a + getOption optionName = + let lookupFail :: forall b. String -> b + lookupFail err = + assert `failure` ("config file access failed:" <+> T.pack err) + `twith` (optionName, cfg) + s = fromMaybe (lookupFail "") $ Ini.getOption "ui" optionName cfg + in either lookupFail id $ readEither s + configFont = getOption "font" + configHistoryMax = getOption "historyMax" + configMaxFps = getOption "maxFps" + configNoAnim = getOption "noAnim" + configRunStopMsgs = getOption "runStopMsgs" in ConfigUI{..} -- | Read and parse UI config file. mkConfigUI :: Kind.Ops RuleKind -> IO ConfigUI mkConfigUI corule = do - let cpUIDefault = rcfgUIDefault $ Kind.stdRuleset corule - dataDir <- ConfigIO.appDataDir - cpUI <- ConfigIO.mkConfig cpUIDefault $ dataDir "config.ui.ini" - let conf = parseConfigUI dataDir cpUI - -- Catch syntax errors ASAP, + let stdRuleset = Kind.stdRuleset corule + cfgUIName = rcfgUIName stdRuleset + commentsUIDefault = init $ map (drop 2) $ lines $ rcfgUIDefault stdRuleset -- TODO: init is a hack until Ini accepts empty files + sUIDefault = unlines commentsUIDefault + cfgUIDefault = either (assert `failure`) id $ Ini.parse sUIDefault + dataDir <- appDataDir + let userPath = dataDir cfgUIName <.> "ini" + cfgUser <- do + cpExists <- doesFileExist userPath + if not cpExists + then return Ini.emptyConfig + else do + sUser <- readFile userPath + return $! either (assert `failure`) id $ Ini.parse sUser + let cfgUI = M.unionWith M.union cfgUser cfgUIDefault -- user cfg preferred + conf = parseConfigUI cfgUI + -- Catch syntax errors in complex expressions ASAP, return $! deepseq conf conf + +-- | Get cached BFS data and path or, if not stored, generate, +-- store and return. Due to laziness, they are not calculated until needed. +getCacheBfsAndPath :: forall m. MonadClient m + => ActorId -> Point + -> m (PointArray.Array BfsDistance, Maybe [Point]) +getCacheBfsAndPath aid target = do + seps <- getsClient seps + let pathAndStore :: PointArray.Array BfsDistance + -> m (PointArray.Array BfsDistance, Maybe [Point]) + pathAndStore bfs = do + computePath <- computePathBFS aid + let mpath = computePath target seps bfs + modifyClient $ \cli -> + cli {sbfsD = EM.insert aid (bfs, target, seps, mpath) (sbfsD cli)} + return (bfs, mpath) + mbfs <- getsClient $ EM.lookup aid . sbfsD + case mbfs of + Just (bfs, targetOld, sepsOld, mpath) | targetOld == target + && sepsOld == seps -> + return (bfs, mpath) + Just (bfs, _, _, _) -> pathAndStore bfs + Nothing -> do + bfs <- computeBFS aid + pathAndStore bfs + +getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance) +{-# INLINE getCacheBfs #-} +getCacheBfs aid = do + mbfs <- getsClient $ EM.lookup aid . sbfsD + case mbfs of + Just (bfs, _, _, _) -> return bfs + Nothing -> fmap fst $ getCacheBfsAndPath aid (Point 0 0) + +computeBFS :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance) +computeBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do + b <- getsState $ getActorBody aid + Level{lxsize, lysize} <- getLevel $ blid b + let origin = bpos b + vInitial = PointArray.replicateA lxsize lysize apartBfs + -- Here we don't want '$!', because we want the BFS data lazy. + return ${-keep it!-} fillBfs isEnterable passUnknown origin vInitial + +computePathBFS :: MonadClient m + => ActorId + -> m (Point -> Int -> PointArray.Array BfsDistance + -> Maybe [Point]) +computePathBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do + b <- getsState $ getActorBody aid + let origin = bpos b + -- Here we don't want '$!', because we want the BFS data lazy. + return ${-keep it!-} findPathBfs isEnterable passUnknown origin + +computeAnythingBFS :: MonadClient m + => ((Point -> Point -> MoveLegal) + -> (Point -> Point -> Bool) + -> ActorId + -> m a) + -> ActorId + -> m a +computeAnythingBFS fAnything aid = do + cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops + b <- getsState $ getActorBody aid + lvl <- getLevel $ blid b + smarkSuspect <- getsClient smarkSuspect + sisAI <- getsClient sisAI + -- We treat doors as an open tile and don't add an extra step for opening + -- the doors, because other actors open and use them, too, + -- so it's amortized. We treat unknown tiles specially. + let -- Suspect tiles treated as a kind of unknown. + passSuspect = smarkSuspect || sisAI -- AI checks suspects ASAP + unknownId = ouniqGroup "unknown space" + chAccess = checkAccess cops lvl + chDoorAccess = checkDoorAccess cops lvl + conditions = catMaybes [chAccess, chDoorAccess] + -- Legality of move from a known tile, assuming doors freely openable. + isEnterable :: Point -> Point -> MoveLegal + isEnterable spos tpos = + let tt = lvl `at` tpos + allOK = all (\f -> f spos tpos) conditions + in if tt == unknownId + then if allOK + then MoveToUnknown + else MoveBlocked + else if Tile.isSuspect cotile tt + then if passSuspect && allOK + then MoveToUnknown + else MoveBlocked + else if Tile.isPassable cotile tt && allOK + then MoveToOpen + else MoveBlocked + -- Legality of move from an unknown tile, assuming unknown are open. + passUnknown :: Point -> Point -> Bool + passUnknown = case chAccess of -- spos is unknown, so not a door + Nothing -> \_ tpos -> let tt = lvl `at` tpos + in tt == unknownId + || passSuspect && Tile.isSuspect cotile tt + Just ch -> \spos tpos -> let tt = lvl `at` tpos + in (tt == unknownId + || passSuspect + && Tile.isSuspect cotile tt) + && ch spos tpos + fAnything isEnterable passUnknown aid + +accessCacheBfs :: MonadClient m => ActorId -> Point -> m (Maybe Int) +{-# INLINE accessCacheBfs #-} +accessCacheBfs aid target = do + bfs <- getCacheBfs aid + return $! accessBfs bfs target + +actorAimsPos :: MonadClient m => ActorId -> Point -> m Bool +{-# INLINE actorAimsPos #-} +actorAimsPos aid target = do + bfs <- getCacheBfs aid + b <- getsState $ getActorBody aid + return $! posAimsPos bfs (bpos b) target + +targetDesc :: MonadClientUI m => Maybe Target -> m Text +targetDesc target = do + lidV <- viewedLevel + mleader <- getsClient _sleader + case target of + Just (TEnemy a _) -> + getsState $ bname . getActorBody a + Just (TEnemyPos _ lid p _) -> + return $! if lid == lidV + then "hot spot" <+> (T.pack . show) p + else "a hot spot on level" <+> tshow (abs $ fromEnum lid) + Just (TPoint lid p) -> + return $! if lid == lidV + then "exact spot" <+> (T.pack . show) p + else "an exact spot on level" <+> tshow (abs $ fromEnum lid) + Just TVector{} -> + case mleader of + Nothing -> return "a relative shift" + Just aid -> do + tgtPos <- aidTgtToPos aid lidV target + let invalidMsg = "an invalid relative shift" + validMsg p = "shift to" <+> (T.pack . show) p + return $! maybe invalidMsg validMsg tgtPos + Nothing -> return "cursor location" + +targetDescLeader :: MonadClientUI m => ActorId -> m Text +targetDescLeader leader = do + tgt <- getsClient $ getTarget leader + targetDesc tgt + +targetDescCursor :: MonadClientUI m => m Text +targetDescCursor = do + scursor <- getsClient scursor + targetDesc $ Just scursor + +getLeaderUI :: MonadClientUI m => m ActorId +getLeaderUI = do + cli <- getClient + case _sleader cli of + Nothing -> assert `failure` "leader expected but not found" `twith` cli + Just leader -> return leader + +getArenaUI :: MonadClientUI m => m LevelId +getArenaUI = do + mleader <- getsClient _sleader + case mleader of + Just leader -> getsState $ blid . getActorBody leader + Nothing -> do + side <- getsClient sside + factionD <- getsState sfactionD + let fact = factionD EM.! side + case gquit fact of + Just Status{stDepth} -> return $! toEnum stDepth + Nothing -> do + dungeon <- getsState sdungeon + let (minD, maxD) = + case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of + (Just ((s, _), _), Just ((e, _), _)) -> (s, e) + _ -> assert `failure` "empty dungeon" `twith` dungeon + return $! max minD $ min maxD $ playerEntry $ gplayer fact + +viewedLevel :: MonadClientUI m => m LevelId +viewedLevel = do + arena <- getArenaUI + stgtMode <- getsClient stgtMode + return $! maybe arena tgtLevelId stgtMode + +-- | Calculate the position of an actor's target. +aidTgtToPos :: MonadClient m + => ActorId -> LevelId -> Maybe Target -> m (Maybe Point) +aidTgtToPos aid lidV tgt = + case tgt of + Just (TEnemy a _) -> do + body <- getsState $ getActorBody a + return $! if blid body == lidV + then Just (bpos body) + else Nothing + Just (TEnemyPos _ lid p _) -> + return $! if lid == lidV then Just p else Nothing + Just (TPoint lid p) -> + return $! if lid == lidV then Just p else Nothing + Just (TVector v) -> do + b <- getsState $ getActorBody aid + Level{lxsize, lysize} <- getLevel lidV + let shifted = shiftBounded lxsize lysize (bpos b) v + return $! if shifted == bpos b && v /= Vector 0 0 + then Nothing + else Just shifted + Nothing -> do + scursor <- getsClient scursor + aidTgtToPos aid lidV $ Just scursor + +-- | Check whether one is permitted to aim at a target +-- (this is only checked for actors; positions let player +-- shoot at obstacles, e.g., to destroy them). +-- This assumes @aidTgtToPos@ does not return @Nothing@. +-- +-- Note: Perception is not enough for the check, +-- because the target actor can be obscured by a glass wall +-- or be out of sight range, but in weapon range. +aidTgtAims :: MonadClient m + => ActorId -> LevelId -> Maybe Target -> m (Maybe Text) +aidTgtAims aid lidV tgt = do + case tgt of + Just (TEnemy a _) -> do + body <- getsState $ getActorBody a + let pos = bpos body + b <- getsState $ getActorBody aid + if blid b == lidV then do + aims <- actorAimsPos aid pos + if aims + then return Nothing + else return $ Just "aiming line to the opponent blocked" + else return $ Just "target opponent not on this level" + Just TEnemyPos{} -> return $ Just "target opponent not visible" + Just TPoint{} -> return Nothing + Just TVector{} -> return Nothing + Nothing -> do + scursor <- getsClient scursor + aidTgtAims aid lidV $ Just scursor + +leaderTgtToPos :: MonadClientUI m => m (Maybe Point) +leaderTgtToPos = do + lidV <- viewedLevel + mleader <- getsClient _sleader + case mleader of + Nothing -> return Nothing + Just aid -> do + tgt <- getsClient $ getTarget aid + aidTgtToPos aid lidV tgt + +leaderTgtAims :: MonadClientUI m => m (Maybe Text) +leaderTgtAims = do + lidV <- viewedLevel + mleader <- getsClient _sleader + case mleader of + Nothing -> return $ Just "no leader to target with" + Just aid -> do + tgt <- getsClient $ getTarget aid + aidTgtAims aid lidV tgt + +cursorToPos :: MonadClientUI m => m (Maybe Point) +cursorToPos = do + lidV <- viewedLevel + mleader <- getsClient _sleader + scursor <- getsClient scursor + case mleader of + Nothing -> return Nothing + Just aid -> aidTgtToPos aid lidV $ Just scursor + +-- | Furthest (wrt paths) known position, except under the actor. +furthestKnown :: MonadClient m => ActorId -> m (Maybe Point) +furthestKnown aid = do + bfs <- getCacheBfs aid + getMaxIndex <- rndToAction $ oneOf [ PointArray.maxIndexA + , PointArray.maxLastIndexA ] + let furthestPos = getMaxIndex bfs + dist = bfs PointArray.! furthestPos + return $! if dist <= apartBfs + then assert `failure` (aid, furthestPos, dist) + else if dist == succ apartBfs -- bpos of aid + then Nothing + else Just furthestPos + +-- | Closest reachable unknown tile position, if any. +closestUnknown :: MonadClient m => ActorId -> m (Maybe Point) +closestUnknown aid = do + bfs <- getCacheBfs aid + getMinIndex <- rndToAction $ oneOf [ PointArray.minIndexA + , PointArray.minLastIndexA ] + let closestPos = getMinIndex bfs + dist = bfs PointArray.! closestPos + if dist >= apartBfs then do + body <- getsState $ getActorBody aid + smarkSuspect <- getsClient smarkSuspect + sisAI <- getsClient sisAI + let passSuspect = smarkSuspect || sisAI + when passSuspect $ -- explored fully, including suspect tiles + modifyClient $ \cli -> + cli {sexplored = ES.insert (blid body) (sexplored cli)} + return Nothing + else return $ Just closestPos + +-- TODO: this is costly, because target has to be changed every +-- turn when walking along trail. But inverting the sort and going +-- to the newest smell, while sometimes faster, may result in many +-- actors following the same trail, unless we wipe the trail as soon +-- as target is assigned (but then we don't know if we should keep the target +-- or not, because somebody already followed it). OTOH, trails are not +-- common and so if wiped they can't incur a large total cost. +-- TODO: remove targets where the smell is likely to get too old by the time +-- the actor gets there. +-- | Finds smells closest to the actor, except under the actor. +closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Tile.SmellTime))] +closestSmell aid = do + body <- getsState $ getActorBody aid + Level{lsmell} <- getLevel $ blid body + let smells = EM.assocs lsmell + case smells of + [] -> return [] + _ -> do + bfs <- getCacheBfs aid + let ts = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) smells + ds = filter (\(d, _) -> d /= 0) ts -- bpos of aid + return $! sortBy (comparing (fst &&& timeNegate . snd . snd)) ds + +-- TODO: We assume linear dungeon in @unexploredD@, +-- because otherwise we'd need to calculate shortest paths in a graph, etc. +-- | Closest (wrt paths) triggerable open tiles. +-- The second argument can ever be true only if there's +-- no escape from the dungeon. +closestTriggers :: MonadClient m => Maybe Bool -> Bool -> ActorId -> m [Point] +closestTriggers onlyDir exploredToo aid = do + Kind.COps{cotile} <- getsState scops + body <- getsState $ getActorBody aid + lvl <- getLevel $ blid body + dungeon <- getsState sdungeon + explored <- getsClient sexplored + unexploredD <- unexploredDepth + let allExplored = ES.size explored == EM.size dungeon + unexUp = onlyDir /= Just False && unexploredD 1 (blid body) + unexDown = onlyDir /= Just True && unexploredD (-1) (blid body) + unexEffect (Effect.Ascend p) = if p > 0 then unexUp else unexDown + unexEffect _ = + -- Escape (or guard) only after exploring, for high score, etc. + allExplored + isTrigger + | exploredToo = \t -> Tile.isWalkable cotile t + && not (null $ Tile.causeEffects cotile t) + | otherwise = \t -> Tile.isWalkable cotile t + && any unexEffect (Tile.causeEffects cotile t) + f :: [Point] -> Point -> Kind.Id TileKind -> [Point] + f acc p t = if isTrigger t then p : acc else acc + let triggersAll = PointArray.ifoldlA f [] $ ltile lvl + -- Don't target stairs under the actor. Most of the time they + -- are blocked and stay so, so we seek other stairs, if any. + -- If no other stairs in this direction, let's wait here. + triggers | length triggersAll > 1 = delete (bpos body) triggersAll + | otherwise = triggersAll + case triggers of + [] -> return [] + _ -> do + bfs <- getCacheBfs aid + let ds = mapMaybe (\p -> fmap (,p) (accessBfs bfs p)) triggers + return $! map snd $ sortBy (comparing fst) ds + +unexploredDepth :: MonadClient m => m (Int -> LevelId -> Bool) +unexploredDepth = do + dungeon <- getsState sdungeon + explored <- getsClient sexplored + let allExplored = ES.size explored == EM.size dungeon + unexploredD p = + let unex lid = allExplored && lescape (dungeon EM.! lid) + || ES.notMember lid explored + || unexploredD p lid + in any unex . ascendInBranch dungeon p + return unexploredD + +-- | Closest (wrt paths) items. +closestItems :: MonadClient m => ActorId -> m ([(Int, (Point, ItemBag))]) +closestItems aid = do + body <- getsState $ getActorBody aid + Level{lfloor} <- getLevel $ blid body + let items = EM.assocs lfloor + case items of + [] -> return [] + _ -> do + bfs <- getCacheBfs aid + let ds = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) items + return $! sortBy (comparing fst) ds + +-- | Closest (wrt paths) enemy actors. +closestFoes :: MonadClient m => ActorId -> m [(Int, (ActorId, Actor))] +closestFoes aid = do + body <- getsState $ getActorBody aid + fact <- getsState $ \s -> sfactionD s EM.! bfid body + foes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid body) + case foes of + [] -> return [] + _ -> do + bfs <- getCacheBfs aid + let ds = mapMaybe (\x@(_, b) -> fmap (,x) (accessBfs bfs (bpos b))) foes + return $! sortBy (comparing fst) ds + +actorAbilities :: MonadClient m => ActorId -> Maybe ActorId -> m [Ability] +actorAbilities aid mleader = do + Kind.COps{ coactor=Kind.Ops{okind} + , cofaction=Kind.Ops{okind=fokind} } <- getsState scops + body <- getsState $ getActorBody aid + fact <- getsState $ (EM.! bfid body) . sfactionD + let factionAbilities + | Just aid == mleader = fAbilityLeader $ fokind $ gkind fact + | otherwise = fAbilityOther $ fokind $ gkind fact + return $! acanDo (okind $ bkind body) `intersect` factionAbilities diff --git a/Game/LambdaHack/Client/Action/ActionClass.hs b/Game/LambdaHack/Client/Action/ActionClass.hs --- a/Game/LambdaHack/Client/Action/ActionClass.hs +++ b/Game/LambdaHack/Client/Action/ActionClass.hs @@ -4,15 +4,12 @@ -- and 'TypeAction'. module Game.LambdaHack.Client.Action.ActionClass where -import Control.Monad.Writer.Strict (WriterT (WriterT), lift, runWriterT) -import Data.Monoid import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Client.Binding import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Msg import Game.LambdaHack.Frontend (FrontReq) -- | The information that is constant across a client playing session, @@ -42,37 +39,14 @@ liftIO :: IO a -> m a saveClient :: m () -instance (Monoid a, MonadClient m) => MonadClient (WriterT a m) where - getClient = lift getClient - getsClient = lift . getsClient - modifyClient = lift . modifyClient - putClient = lift . putClient - liftIO = lift . liftIO - saveClient = lift saveClient - class MonadClient m => MonadClientUI m where getsSession :: (SessionUI -> a) -> m a -instance (Monoid a, MonadClientUI m) => MonadClientUI (WriterT a m) where - getsSession = lift . getsSession - class MonadClient m => MonadClientReadServer c m | m -> c where readServer :: m c class MonadClient m => MonadClientWriteServer d m | m -> d where writeServer :: d -> m () - --- | The bottom of the action monads class semilattice. -class MonadClient m => MonadClientAbort m where - -- Set the current exception handler. First argument is the handler, - -- second is the computation the handler scopes over. - tryWith :: (Msg -> m a) -> m a -> m a - -- Abort with the given message. - abortWith :: Msg -> m a - -instance (Monoid a, MonadClientAbort m) => MonadClientAbort (WriterT a m) where - tryWith exc m = WriterT $ tryWith (runWriterT . exc) (runWriterT m) - abortWith = lift . abortWith saveName :: FactionId -> Bool -> String saveName side isAI = diff --git a/Game/LambdaHack/Client/Action/ActionType.hs b/Game/LambdaHack/Client/Action/ActionType.hs --- a/Game/LambdaHack/Client/Action/ActionType.hs +++ b/Game/LambdaHack/Client/Action/ActionType.hs @@ -1,133 +1,92 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, + MultiParamTypeClasses #-} -- | The main game action monad type implementation. Just as any other -- component of the library, this implementation can be substituted. -- This module should not be imported anywhere except in 'Action' -- to expose the executor to any code using the library. module Game.LambdaHack.Client.Action.ActionType - ( FunActionCli, ActionCli, executorCli + ( ActionCli, executorCli ) where import Control.Applicative import Control.Concurrent.STM -import Control.Monad -import qualified Data.EnumMap.Strict as EM +import qualified Control.Monad.IO.Class as IO +import Control.Monad.Trans.State.Strict hiding (State) import Data.Maybe -import qualified Data.Text as T import System.FilePath -import qualified System.Random as R import Game.LambdaHack.Client.Action.ActionClass -import Game.LambdaHack.Client.Config import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Animation import Game.LambdaHack.Common.ClientCmd -import Game.LambdaHack.Common.Msg import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State --- | The type of the function inside any client action. -type FunActionCli c d a = - SessionUI -- ^ client UI setup data - -> (ChanServer c d, Save.ChanSave (State, StateClient)) - -- ^ this client connection information - -> (State -> StateClient -> a -> IO ()) - -- ^ continuation - -> (R.StdGen -> Msg -> IO ()) -- ^ failure/reset continuation - -> State -- ^ current local state - -> StateClient -- ^ current client state - -> IO () - --- | Client parts of actions of human and computer player characters. -newtype ActionCli c d a = ActionCli {runActionCli :: FunActionCli c d a} - --- | Invokes the action continuation on the provided argument. -returnActionCli :: a -> ActionCli c d a -returnActionCli x = ActionCli (\_c _d k _a s cli -> k s cli x) - --- | Distributes the session and shutdown continuation, --- threads the state and history. -bindActionCli :: ActionCli c d a -> (a -> ActionCli c d b) -> ActionCli c d b -bindActionCli m f = ActionCli (\c d k a s cli -> - let next ns ncli x = - runActionCli (f x) c d k a ns ncli - in runActionCli m c d next a s cli) - -instance Monad (ActionCli c d) where - return = returnActionCli - (>>=) = bindActionCli - -instance Applicative (ActionCli c d) where - pure = return - (<*>) = ap - --- TODO: make sure fmap is inlined and all else is inlined here and elsewhere -instance Functor (ActionCli c d) where - fmap f m = - ActionCli (\c d k a s cli -> - runActionCli m c d (\s' cli' -> - k s' cli' . f) a s cli) +data CliState c d = CliState + { cliState :: !State -- ^ current global state + , cliClient :: !StateClient -- ^ current client state + , cliDict :: !(ChanServer c d) -- ^ this client connection information + , cliToSave :: !(Save.ChanSave (State, StateClient)) + -- ^ connection to the save thread + , cliSession :: SessionUI -- ^ UI setup data, empty for AI clients + } -instance MonadClientAbort (ActionCli c d) where - tryWith exc m = - ActionCli (\c d k a s cli -> - let runA srandom msg = - runActionCli (exc msg) c d k a s cli {srandom} - in runActionCli m c d k runA s cli) - abortWith msg = ActionCli (\_c _d _k a _s cli -> a (srandom cli) msg) +-- | Server state transformation monad. +newtype ActionCli c d a = + ActionCli {runActionCli :: StateT (CliState c d) IO a} + deriving (Monad, Functor, Applicative) instance MonadActionRO (ActionCli c d) where - getState = ActionCli (\_c _d k _a s cli -> k s cli s) - getsState = (`fmap` getState) + getState = ActionCli $ gets cliState + getsState f = ActionCli $ gets $ f . cliState instance MonadAction (ActionCli c d) where - modifyState f = ActionCli (\_c _d k _a s cli -> k (f s) cli ()) - putState = modifyState . const + modifyState f = ActionCli $ state $ \cliS -> + let newCliS = cliS {cliState = f $ cliState cliS} + in newCliS `seq` ((), newCliS) + putState s = ActionCli $ state $ \cliS -> + let newCliS = cliS {cliState = s} + in newCliS `seq` ((), newCliS) instance MonadClient (ActionCli c d) where - getClient = ActionCli (\_c _d k _a s cli -> k s cli cli) - getsClient = (`fmap` getClient) - modifyClient f = ActionCli (\_c _d k _a s cli -> k s (f cli) ()) - putClient = modifyClient . const - liftIO x = ActionCli (\_c _d k _a s cli -> x >>= k s cli) - saveClient = ActionCli (\_c (_, toSave) k _a s cli -> do - Save.saveToChan toSave (s, cli) - k s cli ()) + getClient = ActionCli $ gets cliClient + getsClient f = ActionCli $ gets $ f . cliClient + modifyClient f = ActionCli $ state $ \cliS -> + let newCliS = cliS {cliClient = f $ cliClient cliS} + in newCliS `seq` ((), newCliS) + putClient s = ActionCli $ state $ \cliS -> + let newCliS = cliS {cliClient = s} + in newCliS `seq` ((), newCliS) + liftIO = ActionCli . IO.liftIO + saveClient = ActionCli $ do + s <- gets cliState + cli <- gets cliClient + toSave <- gets cliToSave + IO.liftIO $ Save.saveToChan toSave (s, cli) instance MonadClientUI (ActionCli c d) where - getsSession f = ActionCli (\c _d k _a s cli -> k s cli (f c)) + getsSession f = ActionCli $ gets $ f . cliSession instance MonadClientReadServer c (ActionCli c d) where - readServer = - ActionCli (\_c (ChanServer{..}, _) k _a s cli -> do - ccmd <- atomically . readTQueue $ fromServer - k s cli ccmd) + readServer = ActionCli $ do + ChanServer{fromServer} <- gets cliDict + IO.liftIO $ atomically . readTQueue $ fromServer instance MonadClientWriteServer d (ActionCli c d) where - writeServer scmd = - ActionCli (\_c (ChanServer{..}, _) k _a s cli -> do - atomically . writeTQueue toServer $ scmd - k s cli ()) + writeServer scmd = ActionCli $ do + ChanServer{toServer} <- gets cliDict + IO.liftIO $ atomically . writeTQueue toServer $ scmd -- | Init the client, then run an action, with a given session, -- state and history, in the @IO@ monad. executorCli :: ActionCli c d () -> SessionUI -> State -> StateClient -> ChanServer c d -> IO () -executorCli m sess s cli d = +executorCli m cliSession cliState cliClient cliDict = let saveFile (_, cli2) = - configAppDataDir (sconfigUI cli2) - fromMaybe "save" (ssavePrefixCli (sdebugCli cli2)) + fromMaybe "save" (ssavePrefixCli (sdebugCli cli2)) <.> saveName (sside cli2) (sisAI cli2) - exe toSave = - runActionCli m - sess - (d, toSave) - (\_ _ _ -> return ()) - (\_ msg -> let err = "unhandled abort for client" - <+> showT (sfactionD s EM.! sside cli) - <+> ":" <+> msg - in fail $ T.unpack err) - s - cli + exe cliToSave = + evalStateT (runActionCli m) CliState{..} in Save.wrapInSaves saveFile exe diff --git a/Game/LambdaHack/Client/AtomicSemCli.hs b/Game/LambdaHack/Client/AtomicSemCli.hs --- a/Game/LambdaHack/Client/AtomicSemCli.hs +++ b/Game/LambdaHack/Client/AtomicSemCli.hs @@ -6,11 +6,12 @@ , drawCmdAtomicUI, drawSfxAtomicUI ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Maybe -import qualified Data.Monoid as Monoid +import Data.Monoid import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Client.Action @@ -33,11 +34,13 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.State +import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.TileKind -import Control.Exception.Assert.Sugar -- * CmdAtomicAI @@ -46,9 +49,18 @@ -- of commands kept for each command received. cmdAtomicFilterCli :: MonadClient m => CmdAtomic -> m [CmdAtomic] cmdAtomicFilterCli cmd = case cmd of + MoveActorA aid _ toP -> do + cmdSml <- deleteSmell aid toP + return $ [cmd] ++ cmdSml + DisplaceActorA source target -> do + bs <- getsState $ getActorBody source + bt <- getsState $ getActorBody target + cmdSource <- deleteSmell source (bpos bt) + cmdTarget <- deleteSmell target (bpos bs) + return $ [cmd] ++ cmdSource ++ cmdTarget AlterTileA lid p fromTile toTile -> do - Kind.COps{cotile = Kind.Ops{okind}} <- getsState scops - lvl@Level{lxsize} <- getLevel lid + Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops + lvl <- getLevel lid let t = lvl `at` p if t == fromTile then return [cmd] @@ -61,7 +73,7 @@ let subject = "" -- a hack, we we don't handle adverbs well verb = "turn into" msg = makeSentence [ "the", MU.Text $ tname $ okind t - , "at position", MU.Text $ showPoint lxsize p + , "at position", MU.Text $ tshow p , "suddenly" -- adverb , MU.SubjectVerbSg subject verb , MU.AW $ MU.Text $ tname $ okind toTile ] @@ -72,17 +84,40 @@ b <- getsState $ getActorBody aid lvl <- getLevel $ blid b let t = lvl `at` p - if t == toTile - then -- Already knows the tile fully. - return [] - else if t == fromTile - then -- Fully ignorant. (No intermediate knowledge possible.) - return [ AlterTileA (blid b) p fromTile toTile -- reveal tile - , cmd -- show the message - ] + return $! + if t == fromTile + then -- Fully ignorant. (No intermediate knowledge possible.) + [ cmd -- show the message + , AlterTileA (blid b) p fromTile toTile -- reveal tile + ] + else if t == toTile + then [cmd] -- Already knows the tile fully, only confirm. else -- Misguided. assert `failure` "LoseTile fails to reset memory" `twith` (aid, p, fromTile, toTile, b, t, cmd) + SpotTileA lid ts -> do + Kind.COps{cotile} <- getsState scops + lvl <- getLevel lid + -- We ignore the server resending us hidden versions of the tiles + -- (and resending us the same data we already got). + -- If the tiles are changed to other variants of the hidden tile, + -- we can still verify by searching, and the UI warns us "obscured". + let notKnown (p, t) = let tClient = lvl `at` p + in t /= tClient + && (not (isSecretPos lvl p) + || t /= Tile.hideAs cotile tClient) + newTs = filter notKnown ts + return $! if null newTs then [] else [SpotTileA lid newTs] + AlterSmellA lid p fromSm _toSm -> do + lvl <- getLevel lid + let msml = EM.lookup p $ lsmell lvl + return $ if msml /= fromSm then + -- Revert to the server smell before server command executes. + -- This is needed due to our hacky removal of traversed smells + -- in @deleteSmell@. + [AlterSmellA lid p msml fromSm, cmd] + else + [cmd] DiscoverA _ _ iid _ -> do disco <- getsClient sdisco item <- getsState $ getItemBody iid @@ -95,14 +130,14 @@ if jkindIx item `EM.notMember` disco then return [] else return [cmd] - PerceptionA lid outPA inPA -> do + PerceptionA lid outPer inPer -> do -- Here we cheat by setting a new perception outright instead of -- in @cmdAtomicSemCli@, to avoid computing perception twice. -- TODO: try to assert similar things as for @atomicRemember@: -- that posCmdAtomic of all the Lose* commands was visible in old Per, -- but is not visible any more. perOld <- getPerFid lid - perceptionA lid outPA inPA + perceptionA lid outPer inPer perNew <- getPerFid lid s <- getState fid <- getsClient sside @@ -111,12 +146,13 @@ -- and keep only those where seenAtomicCli is True; this is even -- cheaper than repeated posToActor (until it's optimized). let outFov = totalVisible perOld ES.\\ totalVisible perNew - outPrio = mapMaybe (\p -> posToActor p lid s) $ ES.elems outFov - fActor aid = - let b = getActorBody aid s - in if bfid b == fid -- optimization; precludes DominateActorA - then Nothing - else Just $ LoseActorA aid b (getActorItem aid s) + outPrio = concatMap (\p -> posToActors p lid s) $ ES.elems outFov + fActor ((aid, b), ais) = + -- TODO: instead of bproj, check that actor sees himself. + if not (bproj b) && bfid b == fid + then Nothing -- optimization: the actor is soon lost anyway, + -- e.g., via DominateActorA, so don't bother + else Just $ LoseActorA aid b ais outActor = mapMaybe fActor outPrio -- Wipe out remembered items on tiles that now came into view. Level{lfloor, lsmell} <- getLevel lid @@ -146,18 +182,29 @@ assert (allB (not . seenOld) psItemSmell) skip -- Verify that we forget only currently seen items and smell. assert (allB seenNew psItemSmell) skip - return $ cmd : outActor ++ inItem ++ inSmell + return $! cmd : outActor ++ inItem ++ inSmell _ -> return [cmd] +deleteSmell :: MonadClient m => ActorId -> Point -> m [CmdAtomic] +deleteSmell aid pos = do + Kind.COps{coactor = Kind.Ops{okind}} <- getsState scops + b <- getsState $ getActorBody aid + let canSmell = asmell $ okind $ bkind b + if canSmell then do + lvl <- getLevel $ blid b + let msml = EM.lookup pos $ lsmell lvl + return $ + maybe [] (\sml -> [AlterSmellA (blid b) pos (Just sml) Nothing]) msml + else return [] + -- | Effect of atomic actions on client state is calculated -- in the global state before the command is executed. --- Clients keep a subset of atomic commands sent by the server --- and add their own. The result of this function is the list of commands --- kept for each command received. cmdAtomicSemCli :: MonadClient m => CmdAtomic -> m () cmdAtomicSemCli cmd = case cmd of - DestroyActorA aid _ _ -> destroyActorA aid - LoseActorA aid _ _ -> destroyActorA aid + CreateActorA aid body _ -> createActorA aid body + DestroyActorA aid b _ -> destroyActorA aid b True + SpotActorA aid body _ -> createActorA aid body + LoseActorA aid b _ -> destroyActorA aid b False LeadFactionA fid source target -> do side <- getsClient sside when (side == fid) $ do @@ -168,66 +215,66 @@ modifyClient $ \cli -> cli {_sleader = target} DiscoverA lid p iid ik -> discoverA lid p iid ik CoverA lid p iid ik -> coverA lid p iid ik - PerceptionA lid outPA inPA -> perceptionA lid outPA inPA - RestartA _ sdisco sfper s sdebugCli _ -> do - side <- getsClient sside - let fact = sfactionD s EM.! side + PerceptionA lid outPer inPer -> perceptionA lid outPer inPer + RestartA side sdisco sfper _ sdebugCli _ -> do shistory <- getsClient shistory sconfigUI <- getsClient sconfigUI isAI <- getsClient sisAI let cli = defStateClient shistory sconfigUI side isAI putClient cli { sdisco , sfper - , _sleader = gleader fact - , sundo = [CmdAtomic cmd] - , sdebugCli} + -- , sundo = [CmdAtomic cmd] + , scurDifficulty = sdifficultyCli sdebugCli + , sdebugCli } ResumeA _fid sfper -> modifyClient $ \cli -> cli {sfper} KillExitA _fid -> killExitA SaveBkpA -> saveClient _ -> return () --- We wipe out the target, because if the actor gets recreated --- on another level, the old position does not make sense. --- And if he is really dead, we avoid a memory leak. -destroyActorA :: MonadClient m => ActorId -> m () -destroyActorA aid = - modifyClient $ \cli -> cli {stargetD = EM.delete aid $ stargetD cli} +createActorA :: MonadClient m => ActorId -> Actor -> m () +createActorA aid _b = do + let affect tgt = case tgt of + TEnemyPos a _ _ permit | a == aid -> TEnemy a permit + _ -> tgt + affect3 (tgt, mpath) = case tgt of + TEnemyPos a _ _ permit | a == aid -> (TEnemy a permit, Nothing) + _ -> (tgt, mpath) + modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)} + modifyClient $ \cli -> cli {scursor = affect $ scursor cli} -perceptionA :: MonadClient m => LevelId -> PerActor -> PerActor -> m () -perceptionA lid outPA inPA = do - cops <- getsState scops - s <- getState +destroyActorA :: MonadClient m => ActorId -> Actor -> Bool -> m () +destroyActorA aid b destroy = do + when destroy $ modifyClient $ updateTarget aid (const Nothing) -- gc + modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli} -- gc + let affect tgt = case tgt of + TEnemy a permit | a == aid -> TEnemyPos a (blid b) (bpos b) permit + -- Don't consider @destroy@, because even if actor dead, it makes + -- sense to go to last known location to loot or find others. + _ -> tgt + affect3 (tgt, mpath) = (affect tgt, mpath) -- old path always good + modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)} + modifyClient $ \cli -> cli {scursor = affect $ scursor cli} + +perceptionA :: MonadClient m => LevelId -> Perception -> Perception -> m () +perceptionA lid outPer inPer = do -- Clients can't compute FOV on their own, because they don't know -- if unknown tiles are clear or not. Server would need to send -- info about properties of unknown tiles, which complicates -- and makes heavier the most bulky data set in the game: tile maps. - -- Note we assume, but do not check that @outPA@ is contained - -- in current perception and @inPA@ has no common part with it. + -- Note we assume, but do not check that @outPer@ is contained + -- in current perception and @inPer@ has no common part with it. -- It would make the already very costly operation even more expensive. perOld <- getPerFid lid -- Check if new perception is already set in @cmdAtomicFilterCli@ -- or if we are doing undo/redo, which does not involve filtering. -- The data structure is strict, so the cheap check can't be any simpler. - let interHead [] = Nothing - interHead ((aid, vis) : _) = - Just $ pvisible vis `ES.intersection` - maybe ES.empty pvisible (EM.lookup aid (perActor perOld)) - unset = maybe False ES.null (interHead (EM.assocs inPA)) - || maybe False (not . ES.null) (interHead (EM.assocs outPA)) + let interAlready per = + Just $ totalVisible per `ES.intersection` totalVisible perOld + unset = maybe False ES.null (interAlready inPer) + || maybe False (not . ES.null) (interAlready outPer) when unset $ do - let dummyToPer Perception{perActor} = Perception - { perActor - , ptotal = PerceptionVisible - $ ES.unions $ map pvisible $ EM.elems perActor - , psmell = smellFromActors cops s perActor } - paToDummy perActor = Perception - { perActor - , ptotal = PerceptionVisible ES.empty - , psmell = PerceptionVisible ES.empty } - outPer = paToDummy outPA - inPer = paToDummy inPA - adj Nothing = assert `failure` "no perception to alter" `twith` lid - adj (Just per) = Just $ dummyToPer $ addPer (diffPer per outPer) inPer + let adj Nothing = assert `failure` "no perception to alter" `twith` lid + adj (Just per) = Just $ addPer (diffPer per outPer) inPer f = EM.alter adj lid modifyClient $ \cli -> cli {sfper = f (sfper cli)} @@ -268,23 +315,43 @@ -- the client state is modified by the command. drawCmdAtomicUI :: MonadClientUI m => Bool -> CmdAtomic -> m () drawCmdAtomicUI verbose cmd = case cmd of - CreateActorA aid body _ -> do - when verbose $ actorVerbMU aid body "appear" - lookAtMove aid - DestroyActorA aid body _ -> + CreateActorA aid body _ -> createActorUI aid body verbose "appear" + DestroyActorA aid body _ -> do destroyActorUI aid body "die" "be destroyed" verbose + side <- getsClient sside + when (bfid body == side && not (bproj body)) stopPlayBack CreateItemA _ item k _ -> itemVerbMU item k "drop to the ground" DestroyItemA _ item k _ -> itemVerbMU item k "disappear" + SpotActorA aid body _ -> createActorUI aid body verbose "be spotted" LoseActorA aid body _ -> destroyActorUI aid body "be missing in action" "be lost" verbose + SpotItemA _ item k c -> do + scursorOld <- getsClient scursor + case scursorOld of + TEnemy{} -> return () -- probably too important to overwrite + TEnemyPos{} -> return () + _ -> do + (lid, p) <- posOfContainer c + modifyClient $ \cli -> cli {scursor = TPoint lid p} + stopPlayBack + -- TODO: perhaps don't spam for already seen items; very hard to do + itemVerbMU item k "be spotted" MoveActorA aid _ _ -> lookAtMove aid WaitActorA aid _ _| verbose -> aVerbMU aid "wait" DisplaceActorA source target -> displaceActorUI source target MoveItemA iid k c1 c2 -> moveItemUI verbose iid k c1 c2 - HealActorA aid n | verbose -> - aVerbMU aid $ MU.Text $ if n > 0 - then "heal" <+> showT n <> "HP" - else "be about to lose" <+> showT n <> "HP" + HealActorA aid n -> do + when verbose $ + aVerbMU aid $ MU.Text $ (if n > 0 then "heal" else "lose") + <+> tshow (abs n) <> "HP" + mleader <- getsClient _sleader + when (Just aid == mleader) $ do + Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops + b <- getsState $ getActorBody aid + let ActorKind{ahp} = okind $ bkind b + when (bhp b == maxDice ahp) $ do + actorVerbMU aid b "heal fully" + stopPlayBack HasteActorA aid delta -> aVerbMU aid $ if delta > speedZero then "speed up" @@ -313,13 +380,18 @@ QuitFactionA fid mbody _ toSt -> quitFactionUI fid mbody toSt AlterTileA{} | verbose -> return () -- TODO: door opens - SearchTileA aid _ fromTile toTile -> do + SearchTileA aid p fromTile toTile -> do Kind.COps{cotile = Kind.Ops{okind}} <- getsState scops + b <- getsState $ getActorBody aid + lvl <- getLevel $ blid b subject <- partAidLeader aid - let verb = "reveal that the" + let t = lvl `at` p + verb | t == toTile = "confirm" + | otherwise = "reveal" subject2 = MU.Text $ tname $ okind fromTile verb2 = "be" let msg = makeSentence [ MU.SubjectVerbSg subject verb + , "that the" , MU.SubjectVerbSg subject2 verb2 , "a hidden" , MU.Text $ tname $ okind toTile ] @@ -357,8 +429,7 @@ "look like an ordinary" , objUnkown1, objUnkown2 ] msgAdd msg - RestartA _ _ _ _ _ t -> - msgAdd $ "New game started in" <+> t <+> "mode." + RestartA _ _ _ _ _ t -> msgAdd $ "New game started in" <+> t <+> "mode." SaveBkpA | verbose -> msgAdd "Saving backup." MsgAllA msg -> msgAdd msg _ -> return () @@ -371,8 +442,16 @@ when (not (bproj body) && bfid body == side && isNothing tgtMode) $ do -- targeting does a more extensive look - lookMsg <- lookAt False True (bpos body) aid "" + lookMsg <- lookAt False "" True (bpos body) aid "" msgAdd lookMsg + fact <- getsState $ (EM.! bfid body) . sfactionD + Level{lxsize, lysize} <- getsState $ (EM.! blid body) . sdungeon + if side == bfid body then do + foes <- getsState $ actorList (isAtWar fact) (blid body) + when (foesAdjacent lxsize lysize (bpos body) foes) stopPlayBack + else when (isAtWar fact side) $ do + foes <- getsState $ actorNotProjList (== side) (blid body) + when (foesAdjacent lxsize lysize (bpos body) foes) stopPlayBack -- | Sentences such as \"Dog barks loudly.\". actorVerbMU :: MonadClientUI m => ActorId -> Actor -> MU.Part -> m () @@ -409,6 +488,23 @@ , partItemWs coitem disco k item ] msgAdd msg +-- TODO: "XXX spots YYY"? or blink or show the changed cursor? +createActorUI :: MonadClientUI m => ActorId -> Actor -> Bool -> MU.Part -> m () +createActorUI aid body verbose verb = do + side <- getsClient sside + when (verbose || bfid body /= side) $ actorVerbMU aid body verb + when (bfid body /= side) $ do + fact <- getsState $ (EM.! bfid body) . sfactionD + when (not (bproj body) && isAtWar fact side) $ do + -- Target even if nobody can aim at the enemy. Let's home in on him + -- and then we can aim or melee. We set permit to False, because it's + -- technically very hard to check aimability here, because we are + -- in-between turns and, e.g., leader's move has not yet been taken + -- into account. + modifyClient $ \cli -> cli {scursor = TEnemy aid False} + stopPlayBack + lookAtMove aid + destroyActorUI :: MonadClientUI m => ActorId -> Actor -> MU.Part -> MU.Part -> Bool -> m () destroyActorUI aid body verb verboseVerb verbose = do @@ -457,18 +553,16 @@ quitFactionUI :: MonadClientUI m => FactionId -> Maybe Actor -> Maybe Status -> m () quitFactionUI fid mbody toSt = do - Kind.COps{coitem=Kind.Ops{okind, ouniqGroup}} <- getsState scops - factionD <- getsState sfactionD - let fact = factionD EM.! fid - fidName = MU.Text $ gname fact + cops@Kind.COps{coitem=Kind.Ops{okind, ouniqGroup}} <- getsState scops + fact <- getsState $ (EM.! fid) . sfactionD + let fidName = MU.Text $ gname fact + horror = isHorrorFact cops fact side <- getsClient sside - spawn <- getsState $ isSpawnFaction fid - summon <- getsState $ isSummonFaction fid let msgIfSide _ | fid /= side = Nothing msgIfSide s = Just s (startingPart, partingPart) = case toSt of - _ | summon && not spawn -> - (Nothing, Nothing) -- Ignore summoned actors factions. + _ | horror -> + (Nothing, Nothing) -- Ignore summoned actors' factions. Just Status{stOutcome=Killed} -> ( Just "be eliminated" , msgIfSide "Let's hope another party can save the day!" ) @@ -514,7 +608,7 @@ startingSlide <- promptToSlideshow moreMsg recordHistory -- we are going to exit or restart, so record itemSlides <- - if EM.null bag then return Monoid.mempty + if EM.null bag then return mempty else do io <- floorItemOverlay bag overlayToSlideshow itemMsg io @@ -525,10 +619,10 @@ shutdownSlide <- promptToSlideshow pp -- TODO: First ESC cancels items display. void $ getInitConfirms ColorFull [] - $ startingSlide Monoid.<> itemSlides + $ startingSlide <> itemSlides -- TODO: Second ESC cancels high score and parting message display. -- The last slide stays onscreen during shutdown, etc. - Monoid.<> scoreSlides Monoid.<> partingSlide Monoid.<> shutdownSlide + <> scoreSlides <> partingSlide <> shutdownSlide _ -> return () -- * SfxAtomicUI diff --git a/Game/LambdaHack/Client/Binding.hs b/Game/LambdaHack/Client/Binding.hs --- a/Game/LambdaHack/Client/Binding.hs +++ b/Game/LambdaHack/Client/Binding.hs @@ -1,68 +1,60 @@ --- | Generic binding of keys to commands, procesing macros, --- printing command help. No operation in this module --- involves the 'State' or 'Action' type. +-- | Binding of keys to commands. +-- No operation in this module involves the 'State' or 'Action' type. module Game.LambdaHack.Client.Binding ( Binding(..), stdBinding, keyHelp, ) where import Control.Arrow (second) import qualified Data.Char as Char -import qualified Data.List as L +import Data.List import qualified Data.Map.Strict as M -import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Tuple (swap) import Game.LambdaHack.Client.Config -import Game.LambdaHack.Client.HumanCmd +import Game.LambdaHack.Common.HumanCmd import qualified Game.LambdaHack.Common.Key as K +import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Msg +import Game.LambdaHack.Content.RuleKind -- | Bindings and other information about human player commands. data Binding = Binding - { kcmd :: !(M.Map K.KM (Text, Bool, HumanCmd)) - -- ^ binding keys to commands - , kmacro :: !(M.Map K.KM K.KM) -- ^ macro map - , kmajor :: ![K.KM] -- ^ major commands - , kminor :: ![K.KM] -- ^ minor commands - , krevMap :: !(M.Map HumanCmd K.KM) -- ^ from cmds to their main keys + { bcmdMap :: !(M.Map K.KM (Text, CmdCategory, HumanCmd)) + -- ^ binding of keys to commands + , bcmdList :: ![(K.KM, (Text, CmdCategory, HumanCmd))] + -- ^ the properly ordered list + -- of commands for the help menu + , brevMap :: !(M.Map HumanCmd K.KM) -- ^ and from commands to their keys } -- | Binding of keys to movement and other standard commands, -- as well as commands defined in the config file. -stdBinding :: ConfigUI -- ^ game config - -> Binding -- ^ concrete binding -stdBinding !config@ConfigUI{configMacros} = - let kmacro = M.fromList configMacros +stdBinding :: Kind.Ops RuleKind -- ^ default game rules + -> ConfigUI -- ^ game config + -> Binding -- ^ concrete binding +stdBinding corule !ConfigUI{configCommands} = + let stdRuleset = Kind.stdRuleset corule heroSelect k = ( K.KM { key=K.Char (Char.intToDigit k) , modifier=K.NoModifier } - , SelectHero k ) - cmdList = - configCommands config - ++ K.moveBinding Move Run + , (CmdMeta, PickLeader k) ) + cmdWithHelp = rhumanCommands stdRuleset ++ configCommands + cmdAll = + cmdWithHelp + ++ [(K.mkKM "KP_Begin", (CmdMove, Wait))] + ++ K.moveBinding (\v -> (CmdMove, Move v)) (\v -> (CmdMove, Run v)) ++ fmap heroSelect [0..9] - mkDescribed cmd = (cmdDescription cmd, noRemoteHumanCmd cmd, cmd) - mkCommand = second mkDescribed - semList = L.map mkCommand cmdList + mkDescribed (cat, cmd) = (cmdDescription cmd, cat, cmd) in Binding - { kcmd = M.fromList semList - , kmacro - , kmajor = L.map fst $ L.filter (majorHumanCmd . snd) cmdList - , kminor = L.map fst $ L.filter (minorHumanCmd . snd) cmdList - , krevMap = M.fromList $ map swap cmdList + { bcmdMap = M.fromList $ map (second mkDescribed) cmdAll + , bcmdList = map (second mkDescribed) cmdWithHelp + , brevMap = M.fromList $ map swap $ map (second snd) cmdAll } -coImage :: M.Map K.KM K.KM -> K.KM -> [K.KM] -coImage kmacro k = - let domain = M.keysSet kmacro - in if k `S.member` domain - then [] - else k : [ from | (from, to) <- M.assocs kmacro, to == k ] - -- | Produce a set of help screens from the key bindings. keyHelp :: Binding -> Slideshow -keyHelp Binding{kcmd, kmacro, kmajor, kminor} = +keyHelp Binding{bcmdList} = let movBlurb = [ "Move throughout the level with numerical keypad or" @@ -74,45 +66,47 @@ , " /|\\ /|\\" , " 1 2 3 b j n" , "" - ,"Run ahead until anything disturbs you, with SHIFT (or CTRL) and a key." + , "Run ahead, until anything disturbs you, with SHIFT (or CTRL) and a key." , "Press keypad '5' or '.' to wait a turn, bracing for blows next turn." , "In targeting mode the same keys move the targeting cursor." , "" , "Search, open and attack, by bumping into walls, doors and enemies." , "" - , "Press SPACE to see the next page, with the list of major commands." + , "Press SPACE to see detailed command descriptions." ] - majorBlurb = + categoryBlurb = [ "" - , "Commands marked with * take time and are blocked on remote levels." - , "Press SPACE to see the next page, with the list of minor commands." + , "Press SPACE to see the next page of command descriptions." ] - minorBlurb = + lastBlurb = [ "" , "For more playing instructions see file PLAYING.md." , "Press SPACE to clear the messages and see the map again." ] - fmt k h = T.replicate 16 " " - <> T.justifyLeft 15 ' ' k - <> T.justifyLeft 41 ' ' h - fmts s = " " <> T.justifyLeft 71 ' ' s - blank = fmt "" "" - mov = map fmts movBlurb - major = map fmts majorBlurb - minor = map fmts minorBlurb + fmt k h = T.justifyRight 72 ' ' + $ T.justifyLeft 15 ' ' k + <> T.justifyLeft 41 ' ' h + fmts s = " " <> T.justifyLeft 71 ' ' s + movText = map fmts movBlurb + categoryText = map fmts categoryBlurb + lastText = map fmts lastBlurb keyCaption = fmt "keys" "command" - disp k = T.concat $ map K.showKM $ coImage kmacro k - keys l = [ fmt (disp k) (h <> if timed then "*" else "") - | (k, (h, timed, _)) <- l, h /= "" ] - (kcMajor, kcRest) = - L.partition ((`elem` kmajor) . fst) (M.toAscList kcmd) - (kcMinor, _) = - L.partition ((`elem` kminor) . fst) kcRest - in toSlideshow - [ ["Basic keys. [press SPACE to advance]"] ++ [blank] - ++ mov ++ [moreMsg] - , ["Basic keys. [press SPACE to advance]"] ++ [blank] - ++ [keyCaption] ++ keys kcMajor ++ major ++ [moreMsg] - , ["Basic keys."] ++ [blank] - ++ [keyCaption] ++ keys kcMinor ++ minor + coImage :: K.KM -> [K.KM] + coImage k = k : sort [ from + | (from, (_, _, Macro _ [to])) <- bcmdList + , K.mkKM to == k ] + disp k = T.concat $ intersperse " and " $ map K.showKM $ coImage k + keys cat = [ fmt (disp k) h + | (k, (h, cat', _)) <- bcmdList, cat == cat', h /= "" ] + in toSlideshow True + [ ["Basic keys. [press SPACE to advance]"] ++ [""] + ++ movText ++ [moreMsg] + , [categoryDescription CmdMove <> ". [press SPACE to advance]"] ++ [""] + ++ [keyCaption] ++ keys CmdMove ++ categoryText ++ [moreMsg] + , [categoryDescription CmdItem <> ". [press SPACE to advance]"] ++ [""] + ++ [keyCaption] ++ keys CmdItem ++ categoryText ++ [moreMsg] + , [categoryDescription CmdTgt <> ". [press SPACE to advance]"] ++ [""] + ++ [keyCaption] ++ keys CmdTgt ++ categoryText ++ [moreMsg] + , [categoryDescription CmdMeta <> "."] ++ [""] + ++ [keyCaption] ++ keys CmdMeta ++ lastText ] diff --git a/Game/LambdaHack/Client/ClientSem.hs b/Game/LambdaHack/Client/ClientSem.hs --- a/Game/LambdaHack/Client/ClientSem.hs +++ b/Game/LambdaHack/Client/ClientSem.hs @@ -1,255 +1,325 @@ -- | Semantics of most 'CmdClientAI' client commands. module Game.LambdaHack.Client.ClientSem where +import Control.Exception.Assert.Sugar import Control.Monad -import Control.Monad.Writer.Strict (runWriterT) import qualified Data.EnumMap.Strict as EM +import Data.List import qualified Data.Map.Strict as M import Data.Maybe +import Data.Ord import qualified Data.Text as T import Game.LambdaHack.Client.Action import Game.LambdaHack.Client.Binding +import Game.LambdaHack.Client.Config import Game.LambdaHack.Client.Draw -import Game.LambdaHack.Client.HumanCmd -import Game.LambdaHack.Client.HumanLocal import Game.LambdaHack.Client.HumanSem import Game.LambdaHack.Client.RunAction import Game.LambdaHack.Client.State import Game.LambdaHack.Client.Strategy import Game.LambdaHack.Client.StrategyAction -import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.HumanCmd import qualified Game.LambdaHack.Common.Key as K import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Msg -import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State +import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.FactionKind -import Game.LambdaHack.Content.RuleKind -import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency -queryAI :: MonadClient m => ActorId -> m CmdSerTakeTime +queryAI :: MonadClient m => ActorId -> m CmdTakeTimeSer queryAI oldAid = do - Kind.COps{cofaction=Kind.Ops{okind}, corule} <- getsState scops - side <- getsClient sside - fact <- getsState $ \s -> sfactionD s EM.! side - let abilityLeader = fAbilityLeader $ okind $ gkind fact + Kind.COps{cotile, cofaction=Kind.Ops{okind}} <- getsState scops + oldBody <- getsState $ getActorBody oldAid + let side = bfid oldBody + arena = blid oldBody + fact <- getsState $ (EM.! side) . sfactionD + lvl <- getLevel arena + let leaderStuck = waitedLastTurn oldBody + t = lvl `at` bpos oldBody + abilityLeader = fAbilityLeader $ okind $ gkind fact abilityOther = fAbilityOther $ okind $ gkind fact mleader <- getsClient _sleader - if -- Keep the leader: only a leader is allowed to pick another leader. - mleader /= Just oldAid - -- Keep the leader: abilities are the same (we assume leader can do - -- at least as much as others). - || abilityLeader == abilityOther - -- Keep the leader: other members can't melee. - || Ability.Melee `notElem` abilityOther - then queryAIPick oldAid - else do - fper <- getsClient sfper - oldBody <- getsState $ getActorBody oldAid - oldAis <- getsState $ getActorItem oldAid - btarget <- getsClient $ getTarget oldAid - let arena = blid oldBody - -- Visibility ignored --- every foe is visible by somebody. - foes <- getsState $ actorNotProjList (isAtWar fact) arena - ours <- getsState $ actorNotProjAssocs (== side) arena - time <- getsState $ getLocalTime arena - Level{lxsize, lysize} <- getsState $ \s -> sdungeon s EM.! arena - actorD <- getsState sactorD - let oldPos = bpos oldBody - per = fper EM.! arena - posOnLevel b | blid b /= arena = Nothing - | otherwise = Just $ bpos b - mfoePos foe = maybe Nothing posOnLevel - $ EM.lookup foe actorD - canSee foe = maybe False (actorSeesPos per oldAid) $ mfoePos foe - isAmmo i = jsymbol i `elem` ritemProject (Kind.stdRuleset corule) - hasAmmo = any (isAmmo . snd) oldAis - isAdjacent = foesAdjacent lxsize lysize oldPos foes - if -- Keep the leader: he is alone on the level. - length ours == 1 - -- Keep the leader: he has an enemy target. - || case btarget of - Just (TEnemy foe _) -> - -- and he can shoot it. - canSee foe && hasAmmo && not isAdjacent - _ -> False - -- Keep the leader: he probably just used stairs. - || bpos oldBody == boldpos oldBody - && not (waitedLastTurn oldBody time) - then queryAIPick oldAid - else do - let countMinFoeDist (aid, b) = - let distB = chessDist lxsize (bpos b) - foeDist = map (distB . bpos) foes - minFoeDist | null foeDist = maxBound - | otherwise = minimum foeDist - in ((aid, b), minFoeDist) - oursMinFoeDist = map countMinFoeDist ours - inMelee (_, minFoeDist) = minFoeDist == 1 - oursMeleePos = map (bpos . snd . fst) - $ filter inMelee oursMinFoeDist - let f ((aid, b), minFoeDist) = - let distB = chessDist lxsize (bpos b) - meleeDist = map distB oursMeleePos - minMeleeDist | null meleeDist = maxBound - | otherwise = minimum meleeDist - proximityMelee = max 0 $ 10 - minMeleeDist - proximityFoe = max 0 $ 20 - minFoeDist - distToLeader = distB oldPos - proximityLeader = max 0 $ 10 - distToLeader - in if minFoeDist == 1 - || bhp b <= 0 - || aid == oldAid && waitedLastTurn b time - then -- Ignore: in melee range or incapacitated or stuck. - Nothing - else -- Help in melee, shoot or chase foes, - -- fan out away from each other, if too close. - Just ( 1 - + proximityMelee * 9 - + proximityFoe * 6 - + proximityLeader * 3 - , aid ) - candidates = mapMaybe f oursMinFoeDist - freq | null candidates = toFreq "old leader" [(1, oldAid)] - | otherwise = toFreq "candidates for AI leader" candidates - aid <- rndToAction $ frequency freq + ours <- getsState $ actorNotProjAssocs (== side) arena + let pickOld = do + void $ refreshTarget oldAid (oldAid, oldBody) + queryAIPick (oldAid, oldBody) + case ours of + _ | -- Keep the leader: only a leader is allowed to pick another leader. + mleader /= Just oldAid + -- Keep the leader: abilities are the same (we assume leader can do + -- at least as much as others). TODO: check not accurate, + -- instead define 'movesThisTurn' and use elsehwere. + || abilityLeader == abilityOther + -- Keep the leader: spawners can't change leaders themselves. + || isSpawnFact fact + -- Keep the leader: he is on stairs and not stuck + -- and we don't want to clog stairs or get pushed to another level. + || not leaderStuck && Tile.isStair cotile t + -> pickOld + [] -> assert `failure` (oldAid, oldBody) + [_] -> pickOld -- Keep the leader: he is alone on the level. + (captain, captainBody) : (sergeant, sergeantBody) : _ -> do + -- At this point we almost forget who the old leader was + -- and treat all party actors the same, eliminating candidates + -- until we can't distinguish them any more, at which point we prefer + -- the old leader, if he is among the best candidates + -- (to make the AI appear more human-like to easier to observe). + -- TODO: this also takes melee into account, not shooting. + oursTgt <- fmap catMaybes $ mapM (refreshTarget oldAid) ours + let targetTEnemy (_, (TEnemy{}, _)) = True + targetTEnemy _ = False + (oursTEnemy, oursOther) = partition targetTEnemy oursTgt + -- These are not necessarily stuck (perhaps can go around), + -- but their current path is blocked by friends. + targetBlocked our@((_aid, _b), (_tgt, (path, _etc))) = + let next = case path of + [] -> assert `failure` our + [_goal] -> Nothing + _ : q : _ -> Just q + in any ((== next) . Just . bpos . snd) ours +-- TODO: stuck actors are picked while others close could approach an enemy; +-- we should detect stuck actors (or one-sided stuck) +-- so far we only detect blocked and only in Other mode +-- && not (aid == oldAid && waitedLastTurn b time) -- not stuck +-- this only prevents staying stuck + (oursBlocked, oursPos) = partition targetBlocked oursOther + valueOurs :: ((ActorId, Actor), (Target, PathEtc)) + -> (Int, Int, Bool) + valueOurs our@((aid, b), (TEnemy{}, (_, (_, d)))) = + -- TODO: take weapon, walk and fight speed, etc. into account + ( d + if targetBlocked our then 2 else 0 -- possible delay, hacky + , - 10 * (bhp b `div` 10) + , aid /= oldAid ) + valueOurs ((aid, b), (_tgt, (_path, (goal, d)))) = + -- Keep proper formation, not too dense, not to sparse. + let -- TODO: vary the parameters according to the stage of game, + -- enough equipment or not, game mode, level map, etc. + minSpread = 7 + maxSpread = 12 * 2 + dcaptain p = + chessDistVector $ displacement p (bpos captainBody) + dsergeant p = + chessDistVector $ displacement p (bpos sergeantBody) + minDist | aid == captain = dsergeant (bpos b) + | aid == sergeant = dcaptain (bpos b) + | otherwise = dsergeant (bpos b) + `min` dcaptain (bpos b) + pDist p = dcaptain p + dsergeant p + sumDist = pDist (bpos b) + -- Positive, if the goal gets us closer to the party. + diffDist = sumDist - pDist goal + minCoeff | minDist < minSpread = + (minDist - minSpread) `div` 3 + - if aid == oldAid then 3 else 0 + | otherwise = 0 + explorationValue = diffDist * (sumDist `div` 4) +-- TODO: this half is not yet ready: +-- instead spread targets between actors; moving many actors +-- to a single target and stopping and starting them +-- is very wasteful; also, pick targets not closest to the actor in hand, +-- but to the sum of captain and sergant or something + sumCoeff | sumDist > maxSpread = - explorationValue + | otherwise = 0 + in ( if d == 0 then d + else max 1 $ minCoeff + if d < 10 + then 3 + d `div` 4 + else 9 + d `div` 10 + , sumCoeff + , aid /= oldAid ) + sortOurs = sortBy $ comparing valueOurs + goodGeneric _our@((aid, b), (_tgt, _pathEtc)) = + bhp b > 0 -- not incapacitated + && not (aid == oldAid && waitedLastTurn b) -- not stuck + goodTEnemy our@((_aid, b), (_tgt, (_path, (goal, _d)))) = + not (adjacent (bpos b) goal) -- not in melee range already + && goodGeneric our + oursTEnemyGood = filter goodTEnemy oursTEnemy + oursPosGood = filter goodGeneric oursPos + oursBlockedGood = filter goodGeneric oursBlocked + candidates = sortOurs oursTEnemyGood + ++ sortOurs oursPosGood + ++ sortOurs oursBlockedGood + case candidates of + [] -> queryAIPick (oldAid, oldBody) + c : _ -> do + let best = takeWhile ((== valueOurs c) . valueOurs) candidates + freq = uniformFreq "candidates for AI leader" best + ((aid, b), _) <- rndToAction $ frequency freq s <- getState modifyClient $ updateLeader aid s - queryAIPick aid + queryAIPick (aid, b) -queryAIPick :: MonadClient m => ActorId -> m CmdSerTakeTime -queryAIPick aid = do - Kind.COps{cofaction=Kind.Ops{okind}} <- getsState scops +refreshTarget :: MonadClient m + => ActorId -> (ActorId, Actor) + -> m (Maybe ((ActorId, Actor), (Target, PathEtc))) +refreshTarget oldLeader (aid, body) = do side <- getsClient sside - body <- getsState $ getActorBody aid + assert (bfid body == side `blame` "AI tries to move an enemy actor" + `twith` (aid, body, side)) skip + assert (not (bproj body) `blame` "AI gets to manually move its projectiles" + `twith` (aid, body, side)) skip + stratTarget <- targetStrategy oldLeader aid + tgtMPath <- + if nullStrategy stratTarget then + -- No sensible target, wipe out the old one . + return Nothing + else do + -- Choose a target from those proposed by AI for the actor. + (tgt, path) <- rndToAction $ frequency $ bestVariant stratTarget + return $ Just (tgt, Just path) + let _debug = T.unpack + $ "\nHandleAI symbol:" <+> tshow (bsymbol body) + <> ", aid:" <+> tshow aid + <> ", pos:" <+> tshow (bpos body) + <> "\nHandleAI starget:" <+> tshow stratTarget + <> "\nHandleAI target:" <+> tshow tgtMPath +-- trace _debug skip + modifyClient $ \cli -> + cli {stargetD = EM.alter (const $ tgtMPath) aid (stargetD cli)} + return $! case tgtMPath of + Just (tgt, Just pathEtc) -> Just ((aid, body), (tgt, pathEtc)) + _ -> Nothing + +queryAIPick :: MonadClient m => (ActorId, Actor) -> m CmdTakeTimeSer +queryAIPick (aid, body) = do + side <- getsClient sside assert (bfid body == side `blame` "AI tries to move enemy actor" `twith` (aid, bfid body, side)) skip - mleader <- getsClient _sleader - fact <- getsState $ (EM.! bfid body) . sfactionD - let factionAbilities - | Just aid == mleader = fAbilityLeader $ okind $ gkind fact - | otherwise = fAbilityOther $ okind $ gkind fact - unless (bproj body) $ do - stratTarget <- targetStrategy aid factionAbilities - -- Choose a target from those proposed by AI for the actor. - btarget <- rndToAction $ frequency $ bestVariant stratTarget - let _debug = T.unpack - $ "\nHandleAI abilities:" <+> showT factionAbilities - <> ", symbol:" <+> showT (bsymbol body) - <> ", aid:" <+> showT aid - <> ", pos:" <+> showT (bpos body) - <> "\nHandleAI starget:" <+> showT stratTarget - <> "\nHandleAI target:" <+> showT btarget --- trace _debug skip - modifyClient $ updateTarget aid (const btarget) - stratAction <- actionStrategy aid factionAbilities + assert (not (bproj body) `blame` "AI gets to manually move its projectiles" + `twith` (aid, bfid body, side)) skip + stratAction <- actionStrategy aid -- Run the AI: chose an action from those given by the AI strategy. - action <- rndToAction $ frequency $ bestVariant stratAction - let _debug = T.unpack - $ "HandleAI saction:" <+> showT stratAction - <> "\nHandleAI action:" <+> showT action --- trace _debug skip - return action + rndToAction $ frequency $ bestVariant stratAction -- | Handle the move of a UI player. -queryUI :: (MonadClientAbort m, MonadClientUI m) => ActorId -> m CmdSer +queryUI :: MonadClientUI m => ActorId -> m CmdSer queryUI aid = do - -- When running, stop if aborted by a disturbance. Otherwise let - -- the human player issue commands, until any of them takes time. + side <- getsClient sside + fact <- getsState $ (EM.! side) . sfactionD + -- When running, stop if disturbed. If not running, let the human + -- player issue commands, until any command takes time. leader <- getLeaderUI assert (leader == aid `blame` "player moves not his leader" `twith` (leader, aid)) skip - let inputHumanCmd msg = do - stopRunning - humanCommand msg - tryWith inputHumanCmd $ do - srunning <- getsClient srunning - maybe abort (continueRun leader) srunning - --- | Continue running in the given direction. -continueRun :: MonadClientAbort m => ActorId -> (Vector, Int) -> m CmdSer -continueRun leader dd = do - (dir, distNew) <- continueRunDir leader dd - modifyClient $ \cli -> cli {srunning = Just (dir, distNew)} - -- The potential invisible actor is hit. War is started without asking. - return $ TakeTimeSer $ MoveSer leader dir + srunning <- getsClient srunning + case srunning of + Nothing -> humanCommand Nothing + Just RunParams{runMembers} | isSpawnFact fact && runMembers /= [aid] -> do + stopRunning + ConfigUI{configRunStopMsgs} <- getsClient sconfigUI + let msg = if configRunStopMsgs + then Just $ "Run stop: spawner leader change" + else Nothing + humanCommand msg + Just runParams -> do + runOutcome <- continueRun runParams + case runOutcome of + Left stopMsg -> do + stopRunning + ConfigUI{configRunStopMsgs} <- getsClient sconfigUI + let msg = if configRunStopMsgs + then Just $ "Run stop:" <+> stopMsg + else Nothing + humanCommand msg + Right (paramNew, runCmd) -> do + modifyClient $ \cli -> cli {srunning = Just paramNew} + return $! CmdTakeTimeSer runCmd -- | Determine and process the next human player command. The argument is --- the last abort message due to running, if any. -humanCommand :: forall m. (MonadClientAbort m, MonadClientUI m) - => Msg +-- the last stop message due to running, if any. +humanCommand :: forall m. MonadClientUI m + => Maybe Msg -> m CmdSer -humanCommand msgRunAbort = do - let loop :: Overlay -> m CmdSer - loop overlay = do - km <- getKeyOverlayCommand overlay +humanCommand msgRunStop = do + -- For human UI we invalidate whole @sbfsD@ at the start of each + -- UI player input, which is an overkill, but doesn't affects + -- screensavers, because they are UI, but not human. + modifyClient $ \cli -> cli {sbfsD = EM.empty} + let loop :: Maybe (Bool, Overlay) -> m CmdSer + loop mover = do + (lastBlank, over) <- case mover of + Nothing -> do + -- Display current state if no slideshow or if interrupted. + modifyClient $ \cli -> cli {slastKey = Nothing} + sli <- promptToSlideshow "" + return (False, head . snd $! slideshow sli) + Just bLast -> + -- (Re-)display the last slide while waiting for the next key. + return bLast + (seqCurrent, seqPrevious, k) <- getsClient slastRecord + case k of + 0 -> do + let slastRecord = ([], seqCurrent, 0) + modifyClient $ \cli -> cli {slastRecord} + _ -> do + let slastRecord = ([], seqCurrent ++ seqPrevious, k - 1) + modifyClient $ \cli -> cli {slastRecord} + km <- getKeyOverlayCommand lastBlank over -- Messages shown, so update history and reset current report. recordHistory - -- On abort, just reset state and call loop again below. - -- Each abort that gets this far generates a slide to be shown. - (mcmdS, slides) <- runWriterT $ tryWithSlide (return Nothing) $ do + abortOrCmd <- do -- Look up the key. - Binding{kcmd} <- askBinding - case M.lookup km kcmd of + Binding{bcmdMap} <- askBinding + case M.lookup km bcmdMap of Just (_, _, cmd) -> do -- Query and clear the last command key. lastKey <- getsClient slastKey - -- TODO: perhaps replace slastKey - -- with test 'kmNext == km' - -- or an extra arg to 'loop'. - -- Depends on whether slastKey - -- is needed in other parts of code. - modifyClient (\st -> st {slastKey = Just km}) - cmdHumanSem $ if Just km == lastKey - then Clear - else cmd + stgtMode <- getsClient stgtMode + modifyClient $ \cli -> cli + {swaitTimes = if swaitTimes cli > 0 + then - swaitTimes cli + else 0} + if Just km == lastKey + || km == K.escKey && isNothing stgtMode && isJust mover + then do + modifyClient $ \cli -> cli {slastKey = Nothing} + cmdHumanSem Clear + else do + modifyClient $ \cli -> cli {slastKey = Just km} + cmdHumanSem cmd Nothing -> let msgKey = "unknown command <" <> K.showKM km <> ">" - in abortWith msgKey - -- The command was aborted or successful and if the latter, + in fmap Left $ promptToSlideshow msgKey + -- The command was failed or successful and if the latter, -- possibly took some time. - case mcmdS of - Just cmdS -> do - assert (null (runSlideshow slides) - `blame` "some slides generated for server command" - `twith` slides) skip + case abortOrCmd of + Right cmdS -> do -- Exit the loop and let other actors act. No next key needed -- and no slides could have been generated. - modifyClient (\st -> st {slastKey = Nothing}) + modifyClient $ \cli -> cli {slastKey = Nothing} + case cmdS of + CmdTakeTimeSer cmd -> + modifyClient $ \cli -> cli {slastCmd = Just cmd} + _ -> return () return cmdS - Nothing -> do + Left slides -> do -- If no time taken, rinse and repeat. -- Analyse the obtained slides. - mLast <- case reverse (runSlideshow slides) of + let (onBlank, sli) = slideshow slides + mLast <- case reverse sli of [] -> return Nothing - [sLast] -> return $ Just sLast + [sLast] -> return $ Just (onBlank, sLast) sls@(sLast : _) -> do -- Show, one by one, all slides, awaiting confirmation -- for all but the last one. -- Note: the code that generates the slides is responsible -- for inserting the @more@ prompt. - go <- getInitConfirms ColorFull [km] $ toSlideshow $ reverse sls - return $! if go then Just sLast else Nothing - case mLast of - Nothing -> do - -- Display current state if no slideshow or interrupted. - modifyClient (\st -> st {slastKey = Nothing}) - sli <- promptToSlideshow "" - loop $! head $! runSlideshow sli - Just sLast -> - -- (Re-)display the last slide while waiting for the next key, - loop sLast - sli <- promptToSlideshow msgRunAbort - let overlayInitial = head $ runSlideshow sli - loop overlayInitial + go <- getInitConfirms ColorFull [km] + $ toSlideshow onBlank $ reverse $ map overlay sls + return $! if go then Just (onBlank, sLast) else Nothing + loop mLast + case msgRunStop of + Nothing -> loop Nothing + Just msg -> do + sli <- promptToSlideshow msg + loop $ Just (False, head . snd $ slideshow sli) diff --git a/Game/LambdaHack/Client/Config.hs b/Game/LambdaHack/Client/Config.hs --- a/Game/LambdaHack/Client/Config.hs +++ b/Game/LambdaHack/Client/Config.hs @@ -4,51 +4,25 @@ ) where import Control.DeepSeq -import Data.Binary -import Game.LambdaHack.Client.HumanCmd +import Data.Text (Text) +import Game.LambdaHack.Common.HumanCmd import qualified Game.LambdaHack.Common.Key as K -- | Fully typed contents of the UI config file. This config -- is a part of a game client. data ConfigUI = ConfigUI { -- commands - configCommands :: ![(K.KM, HumanCmd)] - -- files - , configAppDataDir :: !FilePath - , configUICfgFile :: !FilePath - , configSavePrefix :: !String - -- macros - , configMacros :: ![(K.KM, K.KM)] + configCommands :: ![(K.KM, (CmdCategory, HumanCmd))] + -- hero names + , configHeroNames :: ![(Int, Text)] -- ui - , configFont :: !String - , configHistoryMax :: !Int - , configMaxFps :: !Int - , configNoAnim :: !Bool + , configFont :: !String + , configHistoryMax :: !Int + , configMaxFps :: !Int + , configNoAnim :: !Bool + , configRunStopMsgs :: !Bool } deriving Show instance NFData ConfigUI - -instance Binary ConfigUI where - put ConfigUI{..} = do - put configCommands - put configAppDataDir - put configUICfgFile - put configSavePrefix - put configMacros - put configFont - put configHistoryMax - put configMaxFps - put configNoAnim - get = do - configCommands <- get - configAppDataDir <- get - configUICfgFile <- get - configSavePrefix <- get - configMacros <- get - configFont <- get - configHistoryMax <- get - configMaxFps <- get - configNoAnim <- get - return ConfigUI{..} diff --git a/Game/LambdaHack/Client/Draw.hs b/Game/LambdaHack/Client/Draw.hs --- a/Game/LambdaHack/Client/Draw.hs +++ b/Game/LambdaHack/Client/Draw.hs @@ -6,7 +6,7 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import qualified Data.List as L +import Data.List import Data.Maybe import Data.Text (Text) import qualified Data.Text as T @@ -14,10 +14,11 @@ import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Actor as Actor import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Animation (SingleFrame (..)) +import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Effect -import qualified Game.LambdaHack.Common.Feature as F +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Item as Item import qualified Game.LambdaHack.Common.Kind as Kind @@ -25,12 +26,14 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.PointXY +import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.State +import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ActorKind +import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.TileKind -- | Color mode for the display. @@ -39,157 +42,239 @@ | ColorBW -- ^ black+white only -- TODO: split up and generally rewrite. --- | Draw the whole screen: level map, status area and, at most, --- a single page overlay of text divided into lines. -draw :: ColorMode -> Kind.COps -> Perception -> LevelId -> Maybe ActorId - -> StateClient -> State -> Overlay +-- | Draw the whole screen: level map and status area. +-- Pass at most a single page if overlay of text unchanged +-- to the frontends to display separately or overlay over map, +-- depending on the frontend. +draw :: Bool -> ColorMode -> Kind.COps -> Perception -> LevelId + -> Maybe ActorId -> Maybe Point -> Maybe Point + -> Maybe (PointArray.Array BfsDistance, Maybe [Point]) + -> StateClient -> State + -> Text -> Text -> Overlay -> SingleFrame -draw dm cops per drawnLevelId mleader - StateClient{ stgtMode, scursor, seps, sdisco - , smarkVision, smarkSmell, smarkSuspect } - s overlay = - let Kind.COps{cotile=Kind.Ops{okind=tokind, ouniqGroup}} = cops - (lvl@Level{ ldepth, lxsize, lysize, lsmell - , ldesc, ltime, lseen, lclear }) = sdungeon s EM.! drawnLevelId - (msgTop, over, msgBottom) = stringByLocation lxsize lysize overlay - -- TODO: - sVisBG = if smarkVision - then \ vis visPl -> if visPl - then Color.Magenta - else if vis - then Color.Blue - else Color.defBG - else \ _vis _visPl -> Color.defBG - wealth = case mleader of - Nothing -> 0 - Just leader -> snd $ calculateTotal (getActorBody leader s) s - bl = case (scursor, mleader) of +draw sfBlank dm cops per drawnLevelId mleader cursorPos tgtPos bfsmpathRaw + cli@StateClient{ stgtMode, seps, sdisco, sexplored + , smarkVision, smarkSmell, smarkSuspect, swaitTimes } s + cursorDesc targetDesc sfTop = + let Kind.COps{cotile=cotile@Kind.Ops{okind=tokind, ouniqGroup}} = cops + (lvl@Level{lxsize, lysize, lsmell, ltime}) = sdungeon s EM.! drawnLevelId + (bl, blLength) = case (cursorPos, mleader) of (Just cursor, Just leader) -> let Actor{bpos, blid} = getActorBody leader s in if blid /= drawnLevelId - then [] - else fromMaybe [] $ bla lxsize lysize seps bpos cursor + then ([cursor], 0) + else ( fromMaybe [] $ bla lxsize lysize seps bpos cursor + , chessDist bpos cursor ) + _ -> ([], 0) + mpath = maybe Nothing (\(_, mp) -> if blLength == 0 + then Nothing + else mp) bfsmpathRaw + actorsHere = actorAssocs (const True) drawnLevelId s + cursorHere = find (\(_, m) -> cursorPos == Just (Actor.bpos m)) + actorsHere + shiftedBTrajectory = case cursorHere of + Just (_, Actor{btrajectory = Just p, bpos = prPos}) -> trajectoryToPath prPos p _ -> [] - dis pxy = - let pos0 = toPoint lxsize pxy - tile = lvl `at` pos0 + unknownId = ouniqGroup "unknown space" + dis pos0 = + let tile = lvl `at` pos0 tk = tokind tile items = lvl `atI` pos0 sml = EM.findWithDefault timeZero pos0 lsmell smlt = sml `timeAdd` timeNegate ltime viewActor aid Actor{bsymbol, bcolor, bhp, bproj} - | Just aid == mleader = (symbol, Color.defBG) - | otherwise = (symbol, color) + | Just aid == mleader = (symbol, inverseVideo) + | otherwise = (symbol, Color.defAttr {Color.fg = bcolor}) where - color = bcolor symbol | bhp <= 0 && not bproj = '%' | otherwise = bsymbol - rainbow p = toEnum $ fromEnum p `rem` 14 + 1 - actorsHere = actorAssocs (const True) drawnLevelId s + rainbow p = Color.defAttr {Color.fg = + toEnum $ fromEnum p `rem` 14 + 1} -- smarkSuspect is an optional overlay, so let's overlay it -- over both visible and invisible tiles. - vcolor t - | smarkSuspect && F.Suspect `elem` tfeature t = Color.BrCyan - | vis = tcolor t - | otherwise = tcolor2 t - (char, fg0) = - case ( L.find (\ (_, m) -> pos0 == Actor.bpos m) actorsHere - , L.find (\ (_, m) -> scursor == Just (Actor.bpos m)) - actorsHere ) of - (_, actorTgt) | isJust stgtMode - && (L.elem pos0 bl - || (case actorTgt of - Just (_, Actor{ bpath=Just p - , bpos=prPos }) -> - L.elem pos0 $ shiftPath prPos p - _ -> False)) - -> - let unknownId = ouniqGroup "unknown space" - in ('*', case (vis, F.Walkable `elem` tfeature tk) of - _ | tile == unknownId -> Color.BrBlack - (True, True) -> Color.BrGreen - (True, False) -> Color.BrRed - (False, True) -> Color.Green - (False, False) -> Color.Red) - (Just (aid, m), _) -> viewActor aid m + vcolor + | smarkSuspect && Tile.isSuspect cotile tile = Color.BrCyan + | vis = tcolor tk + | otherwise = tcolor2 tk + viewItem i = + ( jsymbol i + , Color.defAttr {Color.fg = flavourToColor $ jflavour i} ) + fgOnPathOrLine = case (vis, Tile.isWalkable cotile tile) of + _ | tile == unknownId -> Color.BrBlack + _ | Tile.isSuspect cotile tile -> Color.BrCyan + (True, True) -> Color.BrGreen + (True, False) -> Color.BrRed + (False, True) -> Color.Green + (False, False) -> Color.Red + atttrOnPathOrLine = if Just pos0 `elem` [cursorPos, tgtPos] + then inverseVideo {Color.fg = fgOnPathOrLine} + else Color.defAttr {Color.fg = fgOnPathOrLine} + (char, attr0) = + case find (\(_, m) -> pos0 == Actor.bpos m) actorsHere of + _ | isJust stgtMode + && (elem pos0 bl || elem pos0 shiftedBTrajectory) -> + ('*', atttrOnPathOrLine) -- line takes precedence over path + _ | isJust stgtMode + && (maybe False (elem pos0) mpath) -> + (';', atttrOnPathOrLine) + Just (aid, m) -> viewActor aid m _ | smarkSmell && smlt > timeZero -> (timeToDigit smellTimeout smlt, rainbow pos0) | otherwise -> case EM.keys items of - [] -> (tsymbol tk, vcolor tk) - i : _ -> Item.viewItem $ getItemBody i s + [] -> (tsymbol tk, Color.defAttr {Color.fg = vcolor}) + i : _ -> viewItem $ getItemBody i s vis = ES.member pos0 $ totalVisible per - visPl = - maybe False (\leader -> actorSeesPos per leader pos0) mleader - bg0 = if isJust stgtMode && Just pos0 == scursor - then Color.defFG -- highlight target cursor - else sVisBG vis visPl -- FOV debug or standard bg - reverseVideo = Color.Attr{ fg = Color.bg Color.defAttr - , bg = Color.fg Color.defAttr - } - optVisually attr@Color.Attr{fg, bg} = - if (fg == Color.defBG) - || (bg == Color.defFG && fg == Color.defFG) - then reverseVideo - else attr + visPl = case (mleader, bfsmpathRaw) of + (Just leader, Just (bfs, _)) -> + let Actor{bpos} = getActorBody leader s + in posAimsPos bfs bpos pos0 + _ -> False a = case dm of ColorBW -> Color.defAttr - ColorFull -> optVisually Color.Attr{fg = fg0, bg = bg0} - in case over pxy of - Just c -> Color.AttrChar Color.defAttr c - _ -> Color.AttrChar a char - leaderStatus = drawLeaderStatus cops s sdisco ltime mleader - seenN = 100 * lseen `div` lclear - seenTxt | seenN == 100 = "all" - | otherwise = T.justifyRight 2 ' ' (showT seenN) <> "%" - lvlN = T.justifyLeft 2 ' ' (showT $ abs ldepth) - stats = - T.justifyLeft 11 ' ' ("[" <> seenTxt <+> "seen]") <+> - T.justifyLeft 9 ' ' ("$:" <+> showT wealth) <+> - leaderStatus - widthForDesc = lxsize - T.length stats - T.length lvlN - 3 - status = lvlN <+> T.justifyLeft widthForDesc ' ' ldesc <+> stats - toWidth :: Int -> Text -> Text - toWidth n x = T.take n (T.justifyLeft n ' ' x) - fLine y = - let f l x = let !ac = dis (PointXY (x, y)) in ac : l - in L.foldl' f [] [lxsize-1,lxsize-2..0] - sfLevel = -- Fully evaluated. + ColorFull -> + if smarkVision + then if visPl + then attr0 {Color.bg = Color.Magenta} + else if vis + then attr0 {Color.bg = Color.Blue} + else attr0 + else attr0 + in Color.AttrChar a char + showN2 n = T.justifyRight 2 ' ' (tshow n) + addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t) + arenaStatus = drawArenaStatus (ES.member drawnLevelId sexplored) lvl + cursorText = (if isJust stgtMode then "cursor>" else "Cursor:") + <+> cursorDesc + lineText = let space = 40 - T.length cursorText - 1 + lText | blLength == 0 = "" + | otherwise = "(line" <+> showN2 blLength <> ")" + in if T.length lText > space + then "" + else T.justifyRight space ' ' lText + cursorStatus = addAttr $ T.justifyLeft 40 ' ' $ cursorText <+> lineText + selectedStatus = drawSelected cli s drawnLevelId mleader + leaderStatus = drawLeaderStatus cops s sdisco swaitTimes mleader + targetText = "Target:" <+> targetDesc + pathText = let space = 40 - T.length targetText - 1 + len = case (tgtPos, bfsmpathRaw) of + (Just target, Just (bfs, _)) -> + fromMaybe 0 (accessBfs bfs target) + _ -> 0 + pText | len == 0 = "" + | otherwise = "(path" <+> showN2 len <> ")" + in if T.length pText > space + then "" + else T.justifyRight space ' ' pText + targetStatus = addAttr $ T.justifyLeft 40 ' ' $ targetText <+> pathText + sfBottom = + [ encodeLine $ arenaStatus ++ cursorStatus + , encodeLine $ selectedStatus ++ leaderStatus ++ targetStatus ] + fLine y = encodeLine $ + let f l x = let ac = dis $ Point x y in ac : l + in foldl' f [] [lxsize-1,lxsize-2..0] + sfLevel = -- fully evaluated let f l y = let !line = fLine y in line : l - in L.foldl' f [] [lysize-1,lysize-2..0] - sfTop = toWidth lxsize msgTop - sfBottom = toWidth (lxsize - 1) $ fromMaybe status msgBottom + in foldl' f [] [lysize-1,lysize-2..0] in SingleFrame{..} -drawLeaderStatus :: Kind.COps -> State -> Discovery -> Time -> Maybe ActorId - -> Text -drawLeaderStatus cops s sdisco ltime mleader = - case mleader of - Just leader -> - let Kind.COps{coactor=Kind.Ops{okind}} = cops - (bitems, bracedL, ahpS, bhpS) = - let mpl@Actor{bkind, bhp} = getActorBody leader s - ActorKind{ahp} = okind bkind - in (getActorItem leader s, braced mpl ltime, - showT (maxDice ahp), showT bhp) - damage = case Item.strongestSword cops bitems of - Just (_, (_, sw)) -> - case Item.jkind sdisco sw of - Just _ -> - case jeffect sw of - Hurt dice p -> showT dice <> "+" <> showT p - _ -> "" - Nothing -> "3d1" -- TODO: ? - Nothing -> "3d1" -- TODO; use the item 'fist' - -- Indicate the actor is braced (was waiting last move). - -- It's a useful feedback for the otherwise hard to observe - -- 'wait' command. - braceSign | bracedL = "{" - | otherwise = " " - in T.justifyLeft 11 ' ' ("Dmg:" <+> damage) <+> - T.justifyLeft 13 ' ' (braceSign <> "HP:" <+> bhpS - <+> "(" <> ahpS <> ")") - Nothing -> - T.justifyLeft 11 ' ' ("Dmg:" <+> "---") <+> - T.justifyLeft 13 ' ' (" " <> "HP:" <+> "--" - <+> "(" <> "--" <> ")") +inverseVideo :: Color.Attr +inverseVideo = Color.Attr { Color.fg = Color.bg Color.defAttr + , Color.bg = Color.fg Color.defAttr } + +drawArenaStatus :: Bool -> Level -> [Color.AttrChar] +drawArenaStatus explored Level{ldepth, ldesc, lseen, lclear} = + let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t) + seenN = 100 * lseen `div` lclear + seenTxt | explored || seenN >= 100 = "all" + | otherwise = T.justifyLeft 3 ' ' (tshow seenN <> "%") + lvlN = T.justifyLeft 2 ' ' (tshow $ abs ldepth) + seenStatus = T.justifyLeft 11 ' ' ("[" <> seenTxt <+> "seen]") + in addAttr $ lvlN <+> T.justifyLeft 25 ' ' ldesc <+> seenStatus + +drawLeaderStatus :: Kind.COps -> State -> Discovery + -> Int -> Maybe ActorId + -> [Color.AttrChar] +drawLeaderStatus cops s sdisco waitTimes mleader = + let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t) + stats = case mleader of + Just leader -> + let Kind.COps{coactor=Kind.Ops{okind}} = cops + (bitems, bracedL, ahpS, bhpS) = + let mpl@Actor{bkind, bhp} = getActorBody leader s + ActorKind{ahp} = okind bkind + in (getActorItem leader s, braced mpl, + tshow (maxDice ahp), tshow bhp) + damage = case Item.strongestSword cops bitems of + Just (_, (_, sw)) -> + case Item.jkind sdisco sw of + Just _ -> + case jeffect sw of + Hurt dice p -> tshow dice <> "+" <> tshow p + _ -> "" + Nothing -> "5d1" -- TODO: ? + Nothing -> "5d1" -- TODO; use the item 'fist' + -- Indicate the actor is braced (was waiting last move). + -- It's a useful feedback for the otherwise hard to observe + -- 'wait' command. + slashes = ["|", "\\", "|", "/"] + slashPick | bracedL = + slashes !! (max 0 (waitTimes - 1) `mod` length slashes) + | otherwise = "/" + bracePick | bracedL = "}" + | otherwise = ":" + hpText = bhpS <> slashPick <> ahpS + in T.justifyLeft 12 ' ' + ("Dmg:" <> (if T.length damage < 8 then " " else "") <> damage) + <+> "HP" <> bracePick <> T.justifyRight 7 ' ' hpText + <> " " + Nothing -> + T.justifyLeft 12 ' ' "Dmg: ---" + <+> T.justifyRight 10 ' ' "HP: --/--" + <> " " + in addAttr stats + +drawSelected :: StateClient -> State -> LevelId -> Maybe ActorId + -> [Color.AttrChar] +drawSelected cli s drawnLevelId mleader = + let selected = sselected cli + viewOurs (aid, Actor{bsymbol, bcolor, bhp}) + | otherwise = + let cattr = Color.defAttr {Color.fg = bcolor} + sattr + | Just aid == mleader = inverseVideo + | ES.member aid selected = + -- TODO: in the future use a red rectangle instead + -- of background and mark them on the map, too; + -- also, perhaps blink all selected on the map, + -- when selection changes + if bcolor /= Color.Blue + then cattr {Color.bg = Color.Blue} + else cattr {Color.bg = Color.Magenta} + | otherwise = cattr + in ( (bhp > 0, bsymbol /= '@', bsymbol, bcolor, aid) + , Color.AttrChar sattr bsymbol ) + ours = actorNotProjAssocs (== sside cli) drawnLevelId s + maxViewed = 14 + -- Don't show anything if the only actor on the level is the leader. + -- He's clearly highlighted on the level map, anyway. + star = let sattr = case ES.size selected of + 0 -> Color.defAttr {Color.fg = Color.BrBlack} + n | n == length ours -> + Color.defAttr {Color.bg = Color.Blue} + _ -> Color.defAttr + char = if length ours > maxViewed then '$' else '*' + in Color.AttrChar sattr char + viewed = take maxViewed $ sort $ map viewOurs ours + addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t) + allOurs = filter ((== sside cli) . bfid) $ EM.elems $ sactorD s + nameN n t = T.justifyLeft n ' ' + $ let firstWord = head $ T.words t + in if T.length firstWord > n then "" else firstWord + fact = sfactionD s EM.! sside cli + ourName n = addAttr $ nameN n $ playerName $ gplayer fact + party = if length allOurs <= 1 + then ourName $ maxViewed + 1 + else [star] ++ map snd viewed ++ addAttr " " + ++ ourName (maxViewed - 1 - length viewed) + in party ++ addAttr (T.replicate (maxViewed + 2 - length party) " ") diff --git a/Game/LambdaHack/Client/HumanCmd.hs b/Game/LambdaHack/Client/HumanCmd.hs deleted file mode 100644 --- a/Game/LambdaHack/Client/HumanCmd.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} --- | Abstract syntax human player commands. -module Game.LambdaHack.Client.HumanCmd - ( HumanCmd(..), Trigger(..) - , majorHumanCmd, minorHumanCmd, noRemoteHumanCmd, cmdDescription - ) where - -import Data.Binary -import Data.Text (Text) -import GHC.Generics (Generic) -import qualified NLP.Miniutter.English as MU - -import Control.Exception.Assert.Sugar -import qualified Game.LambdaHack.Common.Feature as F -import Game.LambdaHack.Common.Msg -import Game.LambdaHack.Common.VectorXY - --- | Abstract syntax of player commands. -data HumanCmd = - -- These usually take time. - Move !VectorXY - | Run !VectorXY - | Wait - | Pickup - | Drop - | Project ![Trigger] - | Apply ![Trigger] - | AlterDir ![Trigger] - | TriggerTile ![Trigger] - -- These do not take time. - | GameRestart !Text - | GameExit - | GameSave - -- These do not notify the server. - | SelectHero !Int - | MemberCycle - | MemberBack - | Inventory - | TgtFloor - | TgtEnemy - | TgtAscend !Int - | EpsIncr !Bool - | Cancel - | Accept - | Clear - | History - | MarkVision - | MarkSmell - | MarkSuspect - | Help - deriving (Show, Read, Eq, Ord, Generic) - -instance Binary HumanCmd - -data Trigger = - ApplyItem {verb :: !MU.Part, object :: !MU.Part, symbol :: !Char} - | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature} - | TriggerFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature} - deriving (Show, Read, Eq, Ord, Generic) - -instance Binary Trigger - --- | Major commands land on the first page of command help. -majorHumanCmd :: HumanCmd -> Bool -majorHumanCmd cmd = case cmd of - Pickup -> True - Drop -> True - Project{} -> True - Apply{} -> True - AlterDir{} -> True - TriggerTile{} -> True - Inventory -> True - Help -> True - _ -> False - --- | Minor commands land on the second page of command help. -minorHumanCmd :: HumanCmd -> Bool -minorHumanCmd cmd = case cmd of - MemberCycle -> True - MemberBack -> True - TgtFloor -> True - TgtEnemy -> True - TgtAscend{} -> True - EpsIncr{} -> True - Cancel -> True - Accept -> True --- Clear -> True - History -> True - MarkVision -> True - MarkSmell -> True - MarkSuspect -> True - _ -> False - --- | Commands that are forbidden on a remote level, because they --- would usually take time when invoked on one. --- Not that movement commands are not included, because they take time --- on normal levels, but don't take time on remote levels, that is, --- in targeting mode. -noRemoteHumanCmd :: HumanCmd -> Bool -noRemoteHumanCmd cmd = case cmd of - Wait -> True - Pickup -> True - Drop -> True - Project{} -> True - Apply{} -> True - AlterDir{} -> True - TriggerTile{} -> True - _ -> False - --- | Description of player commands. -cmdDescription :: HumanCmd -> Text -cmdDescription cmd = case cmd of - Move{} -> "move" - Run{} -> "run" - Wait -> "wait" - Pickup -> "get an object" - Drop -> "drop an object" - Project ts -> triggerDescription ts - Apply ts -> triggerDescription ts - AlterDir ts -> triggerDescription ts - TriggerTile ts -> triggerDescription ts - - GameRestart t -> "new" <+> t <+> "game" - GameExit -> "save and exit" - GameSave -> "save game" - - SelectHero{} -> "select hero" - MemberCycle -> "cycle among heroes on the level" - MemberBack -> "cycle among heroes in the dungeon" - Inventory -> "display inventory" - TgtFloor -> "target position" - TgtEnemy -> "target monster" - TgtAscend k | k == 1 -> "target next shallower level" - TgtAscend k | k >= 2 -> "target" <+> showT k <+> "levels shallower" - TgtAscend k | k == -1 -> "target next deeper level" - TgtAscend k | k <= -2 -> "target" <+> showT (-k) <+> "levels deeper" - TgtAscend _ -> - assert `failure` "void level change when targeting" `twith` cmd - EpsIncr True -> "swerve targeting line" - EpsIncr False -> "unswerve targeting line" - Cancel -> "cancel action" - Accept -> "accept choice" - Clear -> "clear messages" - History -> "display previous messages" - MarkVision -> "mark visible area" - MarkSmell -> "mark smell" - MarkSuspect -> "mark suspect terrain" - Help -> "display help" - -triggerDescription :: [Trigger] -> Text -triggerDescription [] = "trigger a thing" -triggerDescription (t : _) = makePhrase [verb t, MU.AW $ object t] diff --git a/Game/LambdaHack/Client/HumanGlobal.hs b/Game/LambdaHack/Client/HumanGlobal.hs --- a/Game/LambdaHack/Client/HumanGlobal.hs +++ b/Game/LambdaHack/Client/HumanGlobal.hs @@ -2,32 +2,42 @@ -- A couple of them do not take time, the rest does. -- TODO: document module Game.LambdaHack.Client.HumanGlobal - ( moveRunAid, displaceAid, meleeAid, waitHuman, pickupHuman, dropHuman - , projectAid, applyHuman, alterDirHuman, triggerTileHuman + ( -- * Commands that usually take time + moveRunHuman, waitHuman, pickupHuman, dropHuman + , projectHuman, applyHuman, alterDirHuman, triggerTileHuman + , stepToTargetHuman, resendHuman + -- * Commands that never take time , gameRestartHuman, gameExitHuman, gameSaveHuman + -- * Helper definitions + , SlideOrCmd, failWith ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM +import qualified Data.EnumSet as ES import Data.Function import Data.List import Data.Maybe +import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU -import Control.Exception.Assert.Sugar import Game.LambdaHack.Client.Action +import Game.LambdaHack.Client.Config import Game.LambdaHack.Client.Draw -import Game.LambdaHack.Client.HumanCmd (Trigger (..)) import Game.LambdaHack.Client.HumanLocal +import Game.LambdaHack.Client.RunAction import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Feature as F +import Game.LambdaHack.Common.HumanCmd (Trigger (..)) import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Key as K import qualified Game.LambdaHack.Common.Kind as Kind @@ -39,154 +49,212 @@ import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.TileKind as TileKind -abortFailure :: MonadClientAbort m => FailureSer -> m a -abortFailure = abortWith . showFailureSer +type SlideOrCmd a = Either Slideshow a +failWith :: MonadClientUI m => Msg -> m (SlideOrCmd a) +failWith msg = do + modifyClient $ \cli -> cli {slastKey = Nothing} + stopPlayBack + assert (not $ T.null msg) $ fmap Left $ promptToSlideshow msg + +failSlides :: MonadClientUI m => Slideshow -> m (SlideOrCmd a) +failSlides slides = do + modifyClient $ \cli -> cli {slastKey = Nothing} + stopPlayBack + return $ Left slides + +failSer :: MonadClientUI m => FailureSer -> m (SlideOrCmd a) +failSer = failWith . showFailureSer + -- * Move and Run +moveRunHuman :: MonadClientUI m + => Bool -> Vector -> m (SlideOrCmd CmdTakeTimeSer) +moveRunHuman run dir = do + tgtMode <- getsClient stgtMode + if isJust tgtMode then + fmap Left $ moveCursorHuman dir (if run then 10 else 1) + else do + arena <- getArenaUI + leader <- getLeaderUI + sb <- getsState $ getActorBody leader + fact <- getsState $ (EM.! bfid sb) . sfactionD + let tpos = bpos sb `shift` dir + -- We start by checking actors at the the target position, + -- which gives a partial information (actors can be invisible), + -- as opposed to accessibility (and items) which are always accurate + -- (tiles can't be invisible). + tgts <- getsState $ posToActors tpos arena + case tgts of + [] -> do -- move or search or alter + -- Start running in the given direction. The first turn of running + -- succeeds much more often than subsequent turns, because we ignore + -- most of the disturbances, since the player is mostly aware of them + -- and still explicitly requests a run, knowing how it behaves. + runStopOrCmd <- moveRunAid leader dir + case runStopOrCmd of + Left stopMsg -> failWith stopMsg + Right runCmd -> do + sel <- getsClient sselected + let runMembers = if isSpawnFact fact + then [leader] -- TODO: warn? + else ES.toList (ES.delete leader sel) ++ [leader] + runParams = RunParams { runLeader = leader + , runMembers + , runDist = 0 + , runStopMsg = Nothing + , runInitDir = Just dir } + when run $ modifyClient $ \cli -> cli {srunning = Just runParams} + return $ Right runCmd + -- When running, the invisible actor is hit (not displaced!), + -- so that running in the presence of roving invisible + -- actors is equivalent to moving (with visible actors + -- this is not a problem, since runnning stops early enough). + -- TODO: stop running at invisible actor + [((target, _), _)] | run -> + -- Displacing requires accessibility, but it's checked later on. + displaceAid leader target + _ : _ : _ | run -> do + assert (all (bproj . snd . fst) tgts) skip + failSer DisplaceProjectiles + ((target, tb), _) : _ -> do + -- No problem if there are many projectiles at the spot. We just + -- attack the first one. + -- We always see actors from our own faction. + if bfid tb == bfid sb && not (bproj tb) then do + if isSpawnFact fact then + failWith "spawners cannot manually change leaders" + else do + -- Select adjacent actor by bumping into him. Takes no time. + success <- pickLeader target + assert (success `blame` "bump self" + `twith` (leader, target, tb)) skip + return $ Left mempty + else + -- Attacking does not require full access, adjacency is enough. + meleeAid leader target + -- | Actor atttacks an enemy actor or his own projectile. -meleeAid :: (MonadClientAbort m, MonadClientUI m) - => ActorId -> ActorId -> m CmdSerTakeTime +meleeAid :: MonadClientUI m + => ActorId -> ActorId -> m (SlideOrCmd CmdTakeTimeSer) meleeAid source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target sfact <- getsState $ (EM.! bfid sb) . sfactionD - unless (bproj tb || isAtWar sfact (bfid tb)) $ do - go <- displayYesNo ColorBW - "This attack will start a war. Are you sure?" - unless go $ abortWith "Attack canceled." - unless (bproj tb || not (isAllied sfact (bfid tb))) $ do - go <- displayYesNo ColorBW - "You are bound by an alliance. Really attack?" - unless go $ abortWith "Attack canceled." - return $ MeleeSer source target + let returnCmd = return $ Right $ MeleeSer source target + if not (bproj tb || isAtWar sfact (bfid tb)) then do + go1 <- displayYesNo ColorBW + "This attack will start a war. Are you sure?" + if not go1 then failWith "Attack canceled." + else if not (bproj tb || not (isAllied sfact (bfid tb))) then do + go2 <- displayYesNo ColorBW + "You are bound by an alliance. Really attack?" + if not go2 then failWith "Attack canceled." + else returnCmd + else returnCmd + else returnCmd -- Seeing the actor prevents altering a tile under it, but that -- does not limit the player, he just doesn't waste a turn -- on a failed altering. -- | Actor swaps position with another. -displaceAid :: (MonadClientAbort m, MonadClientUI m) - => ActorId -> ActorId -> m CmdSerTakeTime +displaceAid :: MonadClientUI m + => ActorId -> ActorId -> m (SlideOrCmd CmdTakeTimeSer) displaceAid source target = do cops <- getsState scops sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target - let lid = blid sb - lvl <- getLevel lid - let spos = bpos sb - tpos = bpos tb - if accessible cops lvl spos tpos then + let adj = checkAdjacent sb tb + if not adj then failSer DisplaceDistant + else do + let lid = blid sb + lvl <- getLevel lid + let spos = bpos sb + tpos = bpos tb -- Displacing requires full access. - return $ DisplaceSer source target - else abortFailure DisplaceAccess - --- | Actor moves or searches or alters. No visible actor at the position. -moveRunAid :: (MonadClientAbort m, MonadClientUI m) - => ActorId -> Vector -> m CmdSerTakeTime -moveRunAid source dir = do - cops@Kind.COps{cotile} <- getsState scops - sb <- getsState $ getActorBody source - let lid = blid sb - lvl <- getLevel lid - let spos = bpos sb -- source position - tpos = spos `shift` dir -- target position - t = lvl `at` tpos - -- Movement requires full access. - if accessible cops lvl spos tpos then - -- The potential invisible actor is hit. War is started without asking. - return $ MoveSer source dir - -- No access, so search and/or alter the tile. - else if not (Tile.hasFeature cotile F.Walkable t) -- not implied by access - && (Tile.hasFeature cotile F.Suspect t - || Tile.openable cotile t - || Tile.closable cotile t - || Tile.changeable cotile t) then - if not $ EM.null $ lvl `atI` tpos then abortFailure AlterBlockItem - else return $ AlterSer source tpos Nothing - -- We don't use MoveSer, because we don't hit invisible actors here. - -- The potential invisible actor, e.g., in a wall or in - -- an inaccessible doorway, is made known, taking a turn. - -- If server performed an attack for free on the invisible actor anyway, - -- the player (or AI) would be tempted to repeatedly - -- hit random walls in hopes of killing a monster lurking within. - -- If the action had a cost, misclicks would incur the cost, too. - -- Right now the player may repeatedly alter tiles trying to learn - -- about invisible pass-wall actors, but it costs a turn - -- and does not harm the invisible actors, so it's not tempting. - else - -- Ignore a known boring, not accessible tile. - neverMind True + if accessible cops lvl spos tpos then do + tgts <- getsState $ posToActors tpos lid + case tgts of + [] -> assert `failure` (source, sb, target, tb) + [_] -> do + return $ Right $ DisplaceSer source target + _ -> failSer DisplaceProjectiles + else failSer DisplaceAccess -- * Wait -- | Leader waits a turn (and blocks, etc.). -waitHuman :: MonadClientUI m => m CmdSerTakeTime +waitHuman :: MonadClientUI m => m CmdTakeTimeSer waitHuman = do + modifyClient $ \cli -> cli {swaitTimes = abs (swaitTimes cli) + 1} leader <- getLeaderUI - return $ WaitSer leader + return $! WaitSer leader -- * Pickup -pickupHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSerTakeTime +pickupHuman :: MonadClientUI m => m (SlideOrCmd CmdTakeTimeSer) pickupHuman = do leader <- getLeaderUI body <- getsState $ getActorBody leader lvl <- getLevel $ blid body -- Check if something is here to pick up. Items are never invisible. case EM.minViewWithKey $ lvl `atI` bpos body of - Nothing -> abortWith "nothing here" + Nothing -> failWith "nothing here" Just ((iid, k), _) -> do -- pick up first item; TODO: let pl select item item <- getsState $ getItemBody iid let l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing case assignLetter iid l body of - Just l2 -> return $ PickupSer leader iid k l2 - Nothing -> abortWith "cannot carry any more" + Just _ -> return $ Right $ PickupSer leader iid k + Nothing -> failSer PickupOverfull -- * Drop --- TODO: you can drop an item already on the floor, which works correctly, --- but is weird and useless. +-- TODO: you can drop an item already on the floor (the '-' is there), +-- which is weird and useless. -- | Drop a single item. -dropHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSerTakeTime +dropHuman :: MonadClientUI m => m (SlideOrCmd CmdTakeTimeSer) dropHuman = do -- TODO: allow dropping a given number of identical items. Kind.COps{coitem} <- getsState scops leader <- getLeaderUI bag <- getsState $ getActorBag leader inv <- getsState $ getActorInv leader - ((iid, item), (_, container)) <- - getAnyItem leader "What to drop?" bag inv "in inventory" - case container of - CFloor{} -> neverMind True - CActor aid _ -> do - assert (aid == leader) skip - disco <- getsClient sdisco - subject <- partAidLeader leader - msgAdd $ makeSentence - [ MU.SubjectVerbSg subject "drop" - , partItemWs coitem disco 1 item ] - return $ DropSer leader iid + ggi <- getAnyItem leader "What to drop?" bag inv "in inventory" + case ggi of + Right ((iid, item), (_, container)) -> + case container of + CFloor{} -> failWith "never mind" + CActor aid _ -> do + assert (aid == leader) skip + disco <- getsClient sdisco + subject <- partAidLeader leader + msgAdd $ makeSentence + [ MU.SubjectVerbSg subject "drop" + , partItemWs coitem disco 1 item ] + return $ Right $ DropSer leader iid 1 + Left slides -> return $ Left slides allObjectsName :: Text allObjectsName = "Objects" -- | Let the human player choose any item from a list of items. -getAnyItem :: (MonadClientAbort m, MonadClientUI m) +getAnyItem :: MonadClientUI m => ActorId -> Text -- ^ prompt -> ItemBag -- ^ all items in question -> ItemInv -- ^ inventory characters -> Text -- ^ how to refer to the collection of items - -> m ((ItemId, Item), (Int, Container)) + -> m (SlideOrCmd ((ItemId, Item), (Int, Container))) getAnyItem leader prompt = getItem leader prompt (const True) allObjectsName data ItemDialogState = INone | ISuitable | IAll deriving Eq -- | Let the human player choose a single, preferably suitable, -- item from a list of items. -getItem :: (MonadClientAbort m, MonadClientUI m) +getItem :: MonadClientUI m => ActorId -> Text -- ^ prompt message -> (Item -> Bool) -- ^ which items to consider suitable @@ -194,16 +262,16 @@ -> ItemBag -- ^ all items in question -> ItemInv -- ^ inventory characters -> Text -- ^ how to refer to the collection of items - -> m ((ItemId, Item), (Int, Container)) -getItem aid prompt p ptext bag inv isn = do + -> m (SlideOrCmd ((ItemId, Item), (Int, Container))) +getItem aid prompt p ptext bag invRaw isn = do leader <- getLeaderUI b <- getsState $ getActorBody leader lvl <- getLevel $ blid b s <- getState body <- getsState $ getActorBody aid - let checkItem (l, iid) = - fmap (\k -> ((iid, getItemBody iid s), (k, l))) $ EM.lookup iid bag - is0 = mapMaybe checkItem $ EM.assocs inv + let inv = EM.filter (`EM.member` bag) invRaw + checkItem (l, iid) = ((iid, getItemBody iid s), (bag EM.! iid, l)) + is0 = map checkItem $ EM.assocs inv pos = bpos body tis = lvl `atI` pos floorFull = not $ EM.null tis @@ -228,9 +296,9 @@ r = letterRange mls in "[" <> r <> ", ?" <> floorMsg <> bestMsg ask = do - when (null is0 && EM.null tis) $ - abortWith "Not carrying anything." - perform INone + if null is0 && EM.null tis + then failWith "Not carrying anything." + else perform INone invP = EM.filter (\iid -> p (getItemBody iid s)) inv perform itemDialogState = do let (ims, invOver, msg) = case itemDialogState of @@ -238,43 +306,59 @@ ISuitable -> (isp, invP, ptext <+> isn <> ".") IAll -> (is0, inv, allObjectsName <+> isn <> ".") io <- itemOverlay bag invOver - km@K.KM {..} <- - displayChoiceUI (msg <+> choice ims) io (keys ims) - assert (modifier == K.NoModifier) skip - case key of - K.Char '?' -> case itemDialogState of - INone -> perform ISuitable - ISuitable | ptext /= allObjectsName -> perform IAll - _ -> perform INone - K.Char '-' | floorFull -> - -- TODO: let player select item - return $ maximumBy (compare `on` fst . fst) - $ map (\(iid, k) -> - ((iid, getItemBody iid s), - (k, CFloor (blid b) pos))) - $ EM.assocs tis - K.Char l -> - case find ((InvChar l ==) . snd . snd) ims of - Nothing -> assert `failure` "unexpected inventory letter" - `twith` (km, l, ims) - Just (iidItem, (k, l2)) -> - return (iidItem, (k, CActor aid l2)) - K.Return | bestFull -> - let (iidItem, (k, l2)) = maximumBy (compare `on` snd . snd) isp - in return (iidItem, (k, CActor aid l2)) - _ -> assert `failure` "unexpected key:" `twith` km + akm <- displayChoiceUI (msg <+> choice ims) io (keys is0) + case akm of + Left slides -> failSlides slides + Right (km@K.KM {..}) -> do + assert (modifier == K.NoModifier) skip + case key of + K.Char '?' -> case itemDialogState of + INone -> if EM.null invP + then perform IAll + else perform ISuitable + ISuitable | ptext /= allObjectsName -> perform IAll + _ -> perform INone + K.Char '-' | floorFull -> + -- TODO: let player select item + return $ Right + $ maximumBy (compare `on` fst . fst) + $ map (\(iid, k) -> + ((iid, getItemBody iid s), + (k, CFloor (blid b) pos))) + $ EM.assocs tis + K.Char l -> + case find ((InvChar l ==) . snd . snd) is0 of + Nothing -> assert `failure` "unexpected inventory letter" + `twith` (km, l, is0) + Just (iidItem, (k, l2)) -> + return $ Right (iidItem, (k, CActor aid l2)) + K.Return | bestFull -> + let (iidItem, (k, l2)) = maximumBy (compare `on` snd . snd) isp + in return $ Right (iidItem, (k, CActor aid l2)) + _ -> assert `failure` "unexpected key:" `twith` km ask -- * Project -projectAid :: (MonadClientAbort m, MonadClientUI m) - => ActorId -> [Trigger] -> m CmdSerTakeTime -projectAid source ts = do - Kind.COps{cotile} <- getsState scops - target <- targetToPos - let tpos = case target of - Just p -> p - Nothing -> assert `failure` "target unexpectedly invalid" `twith` source +projectHuman :: MonadClientUI m + => [Trigger] -> m (SlideOrCmd CmdTakeTimeSer) +projectHuman ts = do + leader <- getLeaderUI + b <- getsState $ getActorBody leader + tgtPos <- leaderTgtToPos + case tgtPos of + Nothing -> failWith "last target invalid" + Just pos | pos == bpos b -> failWith "cannot aim at oneself" + Just pos -> do + canAim <- leaderTgtAims + case canAim of + Nothing -> projectAid leader ts pos + Just cause -> failWith cause + +projectAid :: MonadClientUI m + => ActorId -> [Trigger] -> Point -> m (SlideOrCmd CmdTakeTimeSer) +projectAid source ts tpos = do + Kind.COps{coactor=Kind.Ops{okind}, cotile} <- getsState scops eps <- getsClient seps sb <- getsState $ getActorBody source let lid = blid sb @@ -283,24 +367,28 @@ Level{lxsize, lysize} <- getLevel lid foes <- getsState $ actorNotProjList (isAtWar fact) lid if foesAdjacent lxsize lysize spos foes - then abortFailure ProjectBlockFoes + then failSer ProjectBlockFoes else do case bla lxsize lysize eps spos tpos of - Nothing -> abortFailure ProjectAimOnself + Nothing -> failSer ProjectAimOnself Just [] -> assert `failure` "project from the edge of level" `twith` (spos, tpos, sb, ts) Just (pos : _) -> do - as <- getsState $ actorList (const True) lid lvl <- getLevel lid let t = lvl `at` pos - if not $ Tile.hasFeature cotile F.Clear t - then abortFailure ProjectBlockTerrain - else if unoccupied as pos - then projectBla source tpos eps ts - else abortFailure ProjectBlockActor + if not $ Tile.isWalkable cotile t + then failSer ProjectBlockTerrain + else do + mab <- getsState $ posToActor pos lid + if maybe True (bproj . snd . fst) mab + then if not (asight $ okind $ bkind sb) + then failSer ProjectBlind + else projectBla source tpos eps ts + else failSer ProjectBlockActor -projectBla :: (MonadClientAbort m, MonadClientUI m) - => ActorId -> Point -> Int -> [Trigger] -> m CmdSerTakeTime +projectBla :: MonadClientUI m + => ActorId -> Point -> Int -> [Trigger] + -> m (SlideOrCmd CmdTakeTimeSer) projectBla source tpos eps ts = do let (verb1, object1) = case ts of [] -> ("aim", "object") @@ -308,14 +396,12 @@ triggerSyms = triggerSymbols ts bag <- getsState $ getActorBag source inv <- getsState $ getActorInv source - ((iid, _), (_, container)) <- - getGroupItem source bag inv object1 triggerSyms - (makePhrase ["What to", verb1 MU.:> "?"]) "in inventory" - stgtMode <- getsClient stgtMode - case stgtMode of - Just (TgtAuto _) -> endTargeting True - _ -> return () - return $! ProjectSer source tpos eps iid container + ggi <- getGroupItem source bag inv object1 triggerSyms + (makePhrase ["What to", verb1 MU.:> "?"]) "in inventory" + case ggi of + Right ((iid, _), (_, container)) -> + return $ Right $ ProjectSer source tpos eps iid container + Left slides -> return $ Left slides triggerSymbols :: [Trigger] -> [Char] triggerSymbols [] = [] @@ -324,8 +410,7 @@ -- * Apply -applyHuman :: (MonadClientAbort m, MonadClientUI m) - => [Trigger] -> m CmdSerTakeTime +applyHuman :: MonadClientUI m => [Trigger] -> m (SlideOrCmd CmdTakeTimeSer) applyHuman ts = do leader <- getLeaderUI bag <- getsState $ getActorBag leader @@ -334,15 +419,17 @@ [] -> ("activate", "object") tr : _ -> (verb tr, object tr) triggerSyms = triggerSymbols ts - ((iid, _), (_, container)) <- - getGroupItem leader bag inv object1 triggerSyms - (makePhrase ["What to", verb1 MU.:> "?"]) "in inventory" - return $! ApplySer leader iid container + ggi <- getGroupItem leader bag inv object1 triggerSyms + (makePhrase ["What to", verb1 MU.:> "?"]) "in inventory" + case ggi of + Right ((iid, _), (_, container)) -> + return $ Right $ ApplySer leader iid container + Left slides -> return $ Left slides -- | Let a human player choose any item with a given group name. -- Note that this does not guarantee the chosen item belongs to the group, -- as the player can override the choice. -getGroupItem :: (MonadClientAbort m, MonadClientUI m) +getGroupItem :: MonadClientUI m => ActorId -> ItemBag -- ^ all objects in question -> ItemInv -- ^ inventory characters @@ -350,7 +437,7 @@ -> [Char] -- ^ accepted item symbols -> Text -- ^ prompt -> Text -- ^ how to refer to the collection of objects - -> m ((ItemId, Item), (Int, Container)) + -> m (SlideOrCmd ((ItemId, Item), (Int, Container))) getGroupItem leader is inv object syms prompt packName = do let choice i = jsymbol i `elem` syms header = makePhrase [MU.Capitalize (MU.Ws object)] @@ -359,23 +446,24 @@ -- * AlterDir -- | Ask for a direction and alter a tile, if possible. -alterDirHuman :: (MonadClientAbort m, MonadClientUI m) - => [Trigger] -> m CmdSerTakeTime +alterDirHuman :: MonadClientUI m => [Trigger] -> m (SlideOrCmd CmdTakeTimeSer) alterDirHuman ts = do let verb1 = case ts of [] -> "alter" tr : _ -> verb tr keys = zipWith K.KM (repeat K.NoModifier) K.dirAllMoveKey prompt = makePhrase ["What to", verb1 MU.:> "? [movement key"] - e <- displayChoiceUI prompt [] keys - leader <- getLeaderUI - b <- getsState $ getActorBody leader - Level{lxsize} <- getLevel $ blid b - K.handleDir lxsize e (flip (alterTile leader) ts) (neverMind True) + me <- displayChoiceUI prompt emptyOverlay keys + case me of + Left slides -> failSlides slides + Right e -> do + leader <- getLeaderUI + K.handleDir e (flip (alterTile leader) ts) (failWith "never mind") -- | Player tries to alter a tile using a feature. -alterTile :: (MonadClientAbort m, MonadClientUI m) - => ActorId -> Vector -> [Trigger] -> m CmdSerTakeTime +alterTile :: MonadClientUI m + => ActorId -> Vector -> [Trigger] + -> m (SlideOrCmd CmdTakeTimeSer) alterTile source dir ts = do Kind.COps{cotile} <- getsState scops b <- getsState $ getActorBody source @@ -384,8 +472,8 @@ t = lvl `at` tpos alterFeats = alterFeatures ts case filter (\feat -> Tile.hasFeature cotile feat t) alterFeats of - [] -> guessAlter cotile alterFeats t - feat : _ -> return $! AlterSer source tpos $ Just feat + [] -> failWith $ guessAlter cotile alterFeats t + feat : _ -> return $ Right $ AlterSer source tpos $ Just feat alterFeatures :: [Trigger] -> [F.Feature] alterFeatures [] = [] @@ -393,30 +481,39 @@ alterFeatures (_ : ts) = alterFeatures ts -- | Guess and report why the bump command failed. -guessAlter :: MonadClientAbort m - => Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> m a -guessAlter cotile (F.OpenTo _ : _) t | Tile.closable cotile t = - abortWith "already open" -guessAlter _ (F.OpenTo _ : _) _ = - abortWith "can't be opened" -guessAlter cotile (F.CloseTo _ : _) t | Tile.openable cotile t = - abortWith "already closed" -guessAlter _ (F.CloseTo _ : _) _ = - abortWith "can't be closed" -guessAlter _ _ _ = neverMind True +guessAlter :: Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> Msg +guessAlter cotile (F.OpenTo _ : _) t + | Tile.isClosable cotile t = "already open" +guessAlter _ (F.OpenTo _ : _) _ = "cannot be opened" +guessAlter cotile (F.CloseTo _ : _) t + | Tile.isOpenable cotile t = "already closed" +guessAlter _ (F.CloseTo _ : _) _ = "cannot be closed" +guessAlter _ _ _ = "never mind" -- * TriggerTile -- | Leader tries to trigger the tile he's standing on. -triggerTileHuman :: (MonadClientAbort m, MonadClientUI m) - => [Trigger] -> m CmdSerTakeTime +triggerTileHuman :: MonadClientUI m + => [Trigger] -> m (SlideOrCmd CmdTakeTimeSer) triggerTileHuman ts = do - leader <- getLeaderUI - triggerTile leader ts + tgtMode <- getsClient stgtMode + if isJust tgtMode then do + let getK tfs = case tfs of + TriggerFeature {feature = F.Cause (Effect.Ascend k)} : _ -> Just k + _ : rest -> getK rest + [] -> Nothing + mk = getK ts + case mk of + Nothing -> failWith "never mind" + Just k -> fmap Left $ tgtAscendHuman k + else do + leader <- getLeaderUI + triggerTile leader ts -- | Player tries to trigger a tile using a feature. -triggerTile :: (MonadClientAbort m, MonadClientUI m) - => ActorId -> [Trigger] -> m CmdSerTakeTime +triggerTile :: MonadClientUI m + => ActorId -> [Trigger] + -> m (SlideOrCmd CmdTakeTimeSer) triggerTile leader ts = do Kind.COps{cotile} <- getsState scops b <- getsState $ getActorBody leader @@ -424,10 +521,12 @@ let t = lvl `at` bpos b triggerFeats = triggerFeatures ts case filter (\feat -> Tile.hasFeature cotile feat t) triggerFeats of - [] -> guessTrigger cotile triggerFeats t + [] -> failWith $ guessTrigger cotile triggerFeats t feat : _ -> do - verifyTrigger leader feat - return $! TriggerSer leader $ Just feat + go <- verifyTrigger leader feat + case go of + Right () -> return $ Right $ TriggerSer leader $ Just feat + Left slides -> return $ Left slides triggerFeatures :: [Trigger] -> [F.Feature] triggerFeatures [] = [] @@ -435,74 +534,114 @@ triggerFeatures (_ : ts) = triggerFeatures ts -- | Verify important feature triggers, such as fleeing the dungeon. -verifyTrigger :: (MonadClientAbort m, MonadClientUI m) - => ActorId -> F.Feature -> m () +verifyTrigger :: MonadClientUI m + => ActorId -> F.Feature -> m (SlideOrCmd ()) verifyTrigger leader feat = case feat of - F.Cause Effect.Escape -> do + F.Cause Effect.Escape{} -> do + cops <- getsState scops b <- getsState $ getActorBody leader side <- getsClient sside - spawn <- getsState $ isSpawnFaction side - summon <- getsState $ isSummonFaction side - when (spawn || summon) $ abortWith + fact <- getsState $ (EM.! side) . sfactionD + let isHero = isHeroFact cops fact + if not isHero then failWith "This is the way out, but where would you go in this alien world?" - go <- displayYesNo ColorFull "This is the way out. Really leave now?" - unless go $ abortWith "Game resumed." - (_, total) <- getsState $ calculateTotal b - when (total == 0) $ do - -- The player can back off at each of these steps. - go1 <- displayMore ColorBW - "Afraid of the challenge? Leaving so soon and empty-handed?" - unless go1 $ abortWith "Brave soul!" - go2 <- displayMore ColorBW - "Next time try to grab some loot before escape!" - unless go2 $ abortWith "Here's your chance!" - _ -> return () + else do + go <- displayYesNo ColorFull "This is the way out. Really leave now?" + if not go then failWith "Game resumed." + else do + (_, total) <- getsState $ calculateTotal b + if total == 0 then do + -- The player can back off at each of these steps. + go1 <- displayMore ColorBW + "Afraid of the challenge? Leaving so soon and empty-handed?" + if not go1 then failWith "Brave soul!" + else do + go2 <- displayMore ColorBW + "Next time try to grab some loot before escape!" + if not go2 then failWith "Here's your chance!" + else return $ Right () + else return $ Right () + _ -> return $ Right () -- | Guess and report why the bump command failed. -guessTrigger :: MonadClientAbort m - => Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> m a +guessTrigger :: Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> Msg guessTrigger cotile fs@(F.Cause (Effect.Ascend k) : _) t | Tile.hasFeature cotile (F.Cause (Effect.Ascend (-k))) t = - if k > 0 then - abortWith "the way goes down, not up" - else if k < 0 then - abortWith "the way goes up, not down" - else - assert `failure` fs + if k > 0 then "the way goes down, not up" + else if k < 0 then "the way goes up, not down" + else assert `failure` fs guessTrigger _ fs@(F.Cause (Effect.Ascend k) : _) _ = - if k > 0 then - abortWith "can't ascend" - else if k < 0 then - abortWith "can't descend" - else - assert `failure` fs -guessTrigger _ _ _ = neverMind True + if k > 0 then "cannot ascend" + else if k < 0 then "cannot descend" + else assert `failure` fs +guessTrigger _ _ _ = "never mind" +-- * StepToTarget + +stepToTargetHuman :: MonadClientUI m => m (SlideOrCmd CmdTakeTimeSer) +stepToTargetHuman = do + tgtMode <- getsClient stgtMode + -- Movement is legal only outside targeting mode. + -- TODO: use this command for something in targeting mode. + if isJust tgtMode then failWith "cannot move in targeting mode" + else do + leader <- getLeaderUI + b <- getsState $ getActorBody leader + tgtPos <- leaderTgtToPos + case tgtPos of + Nothing -> failWith "target not set" + Just c | c == bpos b -> failWith "target reached" + Just c -> do + (_, mpath) <- getCacheBfsAndPath leader c + case mpath of + Nothing -> failWith "no route to target" + Just [] -> assert `failure` (leader, b, bpos b, c) + Just (p1 : _) -> do + as <- getsState $ posToActors p1 (blid b) + if not $ null as then + failWith "actor in the path to target" + else + moveRunHuman False $ towards (bpos b) p1 + +-- * Resend + +resendHuman :: MonadClientUI m => m (SlideOrCmd CmdTakeTimeSer) +resendHuman = do + slastCmd <- getsClient slastCmd + case slastCmd of + Just cmd -> return $ Right cmd + Nothing -> failWith "no time-taking command to repeat" + -- * GameRestart; does not take time -gameRestartHuman :: (MonadClientAbort m, MonadClientUI m) => Text -> m CmdSer +gameRestartHuman :: MonadClientUI m => Text -> m (SlideOrCmd CmdSer) gameRestartHuman t = do let msg = "You just requested a new" <+> t <+> "game." b1 <- displayMore ColorFull msg - unless b1 $ neverMind True - b2 <- displayYesNo ColorBW - "Current progress will be lost! Really restart the game?" - msg2 <- rndToAction $ oneOf - [ "Yea, would be a pity to leave them all to die." - , "Yea, a shame to get your own team stranded." ] - unless b2 $ abortWith msg2 - leader <- getLeaderUI - return $ GameRestartSer leader t + if not b1 then failWith "never mind" + else do + b2 <- displayYesNo ColorBW + "Current progress will be lost! Really restart the game?" + msg2 <- rndToAction $ oneOf + [ "Yea, would be a pity to leave them all to die." + , "Yea, a shame to get your own team stranded." ] + if not b2 then failWith msg2 + else do + leader <- getLeaderUI + DebugModeCli{sdifficultyCli} <- getsClient sdebugCli + ConfigUI{configHeroNames} <- getsClient sconfigUI + return $ Right $ GameRestartSer leader t sdifficultyCli configHeroNames -- * GameExit; does not take time -gameExitHuman :: (MonadClientAbort m, MonadClientUI m) => m CmdSer +gameExitHuman :: MonadClientUI m => m (SlideOrCmd CmdSer) gameExitHuman = do go <- displayYesNo ColorFull "Really save and exit?" if go then do leader <- getLeaderUI - return $ GameExitSer leader - else abortWith "Save and exit canceled." + DebugModeCli{sdifficultyCli} <- getsClient sdebugCli + return $ Right $ GameExitSer leader sdifficultyCli + else failWith "Save and exit canceled." -- * GameSave; does not take time @@ -511,4 +650,4 @@ leader <- getLeaderUI -- TODO: do not save to history: msgAdd "Saving game backup." - return $ GameSaveSer leader + return $! GameSaveSer leader diff --git a/Game/LambdaHack/Client/HumanLocal.hs b/Game/LambdaHack/Client/HumanLocal.hs --- a/Game/LambdaHack/Client/HumanLocal.hs +++ b/Game/LambdaHack/Client/HumanLocal.hs @@ -2,29 +2,33 @@ -- server commands. None of such commands takes game time. -- TODO: document module Game.LambdaHack.Client.HumanLocal - ( -- * Semantics of serverl-less human commands - moveCursor, retargetLeader - , selectHeroHuman, memberCycleHuman, memberBackHuman - , inventoryHuman, tgtFloorLeader, tgtEnemyLeader, tgtAscendHuman - , epsIncrHuman, cancelHuman, displayMainMenu, acceptHuman, clearHuman - , historyHuman, humanMarkVision, humanMarkSmell, humanMarkSuspect - , helpHuman - -- * Helper functions useful also elsewhere - , endTargeting, floorItemOverlay, itemOverlay, viewedLevel, selectLeader - , stopRunning, lookAt + ( -- * Assorted commands that do not notify the server + gameDifficultyCycle + , pickLeaderHuman, memberCycleHuman, memberBackHuman, inventoryHuman + , selectActorHuman, selectNoneHuman, clearHuman, repeatHuman, recordHuman + , historyHuman, markVisionHuman, markSmellHuman, markSuspectHuman + , helpHuman, mainMenuHuman, macroHuman + -- * Commands specific to targeting + , moveCursorHuman, tgtFloorHuman, tgtEnemyHuman + , tgtUnknownHuman, tgtItemHuman, tgtStairHuman, tgtAscendHuman + , epsIncrHuman, tgtClearHuman, cancelHuman, acceptHuman + -- * Helper definitions + , floorItemOverlay, itemOverlay + , pickLeader, lookAt ) where -- Cabal import qualified Paths_LambdaHack as Self (version) +import Control.Exception.Assert.Sugar import Control.Monad -import Control.Monad.Writer.Strict (WriterT, tell) import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Function import Data.List import qualified Data.Map.Strict as M import Data.Maybe +import Data.Monoid import Data.Ord import Data.Text (Text) import qualified Data.Text as T @@ -32,17 +36,17 @@ import Game.LambdaHack.Frontend (frontendName) import qualified NLP.Miniutter.English as MU -import Control.Exception.Assert.Sugar import Game.LambdaHack.Client.Action import Game.LambdaHack.Client.Binding -import qualified Game.LambdaHack.Client.HumanCmd as HumanCmd import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Feature as F +import qualified Game.LambdaHack.Common.HumanCmd as HumanCmd import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Key as K import qualified Game.LambdaHack.Common.Kind as Kind @@ -57,176 +61,54 @@ import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind --- * Move and Run - -moveCursor :: MonadClientUI m => Vector -> Int -> WriterT Slideshow m () -moveCursor dir n = do - leader <- getLeaderUI - lpos <- getsState $ bpos . getActorBody leader - scursor <- getsClient scursor - let cpos = fromMaybe lpos scursor - Level{lxsize, lysize} <- cursorLevel - let shiftB pos = shiftBounded lxsize (1, 1, lxsize - 2, lysize - 2) pos dir - modifyClient $ \cli -> cli {scursor = Just $ iterate shiftB cpos !! n} - doLook - -cursorLevel :: MonadClient m => m Level -cursorLevel = do - dungeon <- getsState sdungeon - stgtMode <- getsClient stgtMode - cli <- getClient - let tgtId = maybe (assert `failure` "not targetting right now" - `twith` cli) tgtLevelId stgtMode - return $! dungeon EM.! tgtId - -viewedLevel :: MonadClientUI m => m (LevelId, Level) -viewedLevel = do - arena <- getArenaUI - dungeon <- getsState sdungeon - stgtMode <- getsClient stgtMode - let tgtId = maybe arena tgtLevelId stgtMode - return (tgtId, dungeon EM.! tgtId) - --- TODO: probably move somewhere (Level?) --- | Produces a textual description of the terrain and items at an already --- explored position. Mute for unknown positions. --- The detailed variant is for use in the targeting mode. -lookAt :: MonadClientUI m - => Bool -- ^ detailed? - -> Bool -- ^ can be seen right now? - -> Point -- ^ position to describe - -> ActorId -- ^ the actor that looks - -> Text -- ^ an extra sentence to print - -> m Text -lookAt detailed canSee pos aid msg = do - Kind.COps{coitem, cotile=cotile@Kind.Ops{okind}} <- getsState scops - (_, lvl) <- viewedLevel - subject <- partAidLeader aid - s <- getState - let is = lvl `atI` pos - verb = MU.Text $ if canSee then "see" else "remember" - disco <- getsClient sdisco - let nWs (iid, k) = partItemWs coitem disco k (getItemBody iid s) - isd = case detailed of - _ | EM.size is == 0 -> "" - _ | EM.size is <= 2 -> - makeSentence [ MU.SubjectVerbSg subject verb - , MU.WWandW $ map nWs $ EM.assocs is] - True -> "Objects:" - _ -> "Objects here." - tile = lvl `at` pos - obscured | tile /= hideTile cotile lvl pos = "partially obscured" - | otherwise = "" - if detailed - then return $! makeSentence [obscured, MU.Text $ tname $ okind tile] - <+> msg <+> isd - else return $! msg <+> isd - --- | Perform look around in the current position of the cursor. --- Assumes targeting mode and so assumes that a leader is selected. -doLook :: MonadClientUI m => WriterT Slideshow m () -doLook = do - scursor <- getsClient scursor - (lid, lvl) <- viewedLevel - per <- getPerFid lid - leader <- getLeaderUI - lpos <- getsState $ bpos . getActorBody leader - target <- getsClient $ getTarget leader - hms <- getsState $ actorList (const True) lid - let p = fromMaybe lpos scursor - canSee = ES.member p (totalVisible per) - ihabitant | canSee = find (\m -> bpos m == p) hms - | otherwise = Nothing - enemyMsg = - -- Even if it's the leader, give his proper name, not 'you'. - maybe "" (\b -> let subject = partActor b - verb = "be here" - in makeSentence [MU.SubjectVerbSg subject verb]) - ihabitant - vis | not $ p `ES.member` totalVisible per = " (not visible)" - | actorSeesPos per leader p = "" - | otherwise = " (not visible)" - mode = case target of - Just TEnemy{} -> "[targeting foe" <> vis <> "]" - Just TPos{} -> "[targeting position" <> vis <> "]" - Nothing -> "[targeting current" <> vis <> "]" - -- Check if there's something lying around at current position. - is = lvl `atI` p - -- Show general info about current position. - lookMsg <- lookAt True canSee p leader enemyMsg - modifyClient (\st -> st {slastKey = Nothing}) - if EM.size is <= 2 then do - slides <- promptToSlideshow (mode <+> lookMsg) - tell slides - else do - io <- floorItemOverlay is - slides <- overlayToSlideshow (mode <+> lookMsg) io - tell slides - --- | Create a list of item names. -floorItemOverlay :: MonadClient m => ItemBag -> m Overlay -floorItemOverlay bag = do - Kind.COps{coitem} <- getsState scops - s <- getState - disco <- getsClient sdisco - let is = zip (EM.assocs bag) (allLetters ++ repeat (InvChar ' ')) - pr ((iid, k), l) = - makePhrase [ letterLabel l - , partItemWs coitem disco k (getItemBody iid s) ] - <> " " - return $ map pr is - --- | Create a list of item names. -itemOverlay :: MonadClient m => ItemBag -> ItemInv -> m Overlay -itemOverlay bag inv = do - Kind.COps{coitem} <- getsState scops - s <- getState - disco <- getsClient sdisco - let checkItem (l, iid) = fmap (\k -> (l, iid, k)) $ EM.lookup iid bag - is = mapMaybe checkItem $ EM.assocs inv - pr (l, iid, k) = - makePhrase [ letterLabel l - , partItemWs coitem disco k (getItemBody iid s) ] - <> " " - return $ map pr is +failWith :: MonadClientUI m => Msg -> m Slideshow +failWith msg = do + modifyClient $ \cli -> cli {slastKey = Nothing} + stopPlayBack + assert (not $ T.null msg) $ promptToSlideshow msg --- * Project +-- * GameDifficultyCycle -retargetLeader :: MonadClientUI m => WriterT Slideshow m () -retargetLeader = do - arena <- getArenaUI - -- TODO: do not save to history: - msgAdd "Last target invalid." - modifyClient $ \cli -> cli {scursor = Nothing, seps = 0} - tgtEnemyLeader $ TgtAuto arena +gameDifficultyCycle :: MonadClientUI m => m () +gameDifficultyCycle = do + DebugModeCli{sdifficultyCli} <- getsClient sdebugCli + let d = if sdifficultyCli <= -4 then 4 else sdifficultyCli - 1 + modifyClient $ \cli -> cli {sdebugCli = (sdebugCli cli) {sdifficultyCli = d}} + msgAdd $ "Next game difficulty set to" <+> tshow (5 - d) <> "." --- * SelectHero +-- * PickLeader -selectHeroHuman :: (MonadClientAbort m, MonadClientUI m) => Int -> m () -selectHeroHuman k = do +pickLeaderHuman :: MonadClientUI m => Int -> m Slideshow +pickLeaderHuman k = do side <- getsClient sside + fact <- getsState $ (EM.! side) . sfactionD s <- getState case tryFindHeroK s side k of - Nothing -> abortWith "No such member of the party." - Just (aid, _) -> void $ selectLeader aid + _ | isSpawnFact fact -> failWith "spawners cannot manually change leaders" + Nothing -> failWith "No such member of the party." + Just (aid, _) -> do + void $ pickLeader aid + return mempty -- * MemberCycle -- | Switches current member to the next on the level, if any, wrapping. -memberCycleHuman :: (MonadClientAbort m, MonadClientUI m) => m () +memberCycleHuman :: MonadClientUI m => m Slideshow memberCycleHuman = do + side <- getsClient sside + fact <- getsState $ (EM.! side) . sfactionD leader <- getLeaderUI body <- getsState $ getActorBody leader hs <- partyAfterLeader leader case filter (\(_, b) -> blid b == blid body) hs of - [] -> abortWith "Cannot select any other member on this level." + _ | isSpawnFact fact -> failWith "spawners cannot manually change leaders" + [] -> failWith "Cannot pick any other member on this level." (np, b) : _ -> do - success <- selectLeader np + success <- pickLeader np assert (success `blame` "same leader" `twith` (leader, np, b)) skip + return mempty -partyAfterLeader :: MonadActionRO m - => ActorId - -> m [(ActorId, Actor)] +partyAfterLeader :: MonadActionRO m => ActorId -> m [(ActorId, Actor)] partyAfterLeader leader = do faction <- getsState $ bfid . getActorBody leader allA <- getsState $ EM.assocs . sactorD @@ -237,49 +119,51 @@ hs = hs9 ++ deleteFirstsBy ((==) `on` fst) factionA hs9 i = fromMaybe (-1) $ findIndex ((== leader) . fst) hs (lt, gt) = (take i hs, drop (i + 1) hs) - return $ gt ++ lt + return $! gt ++ lt -- | Select a faction leader. False, if nothing to do. -selectLeader :: MonadClientUI m => ActorId -> m Bool -selectLeader actor = do +pickLeader :: MonadClientUI m => ActorId -> m Bool +pickLeader actor = do leader <- getLeaderUI stgtMode <- getsClient stgtMode if leader == actor - then return False -- already selected + then return False -- already picked else do pbody <- getsState $ getActorBody actor assert (not (bproj pbody) `blame` "projectile chosen as the leader" `twith` (actor, pbody)) skip -- Even if it's already the leader, give his proper name, not 'you'. let subject = partActor pbody - msgAdd $ makeSentence [subject, "selected"] + msgAdd $ makeSentence [subject, "picked as a leader"] -- Update client state. s <- getState modifyClient $ updateLeader actor s -- Move the cursor, if active, to the new level. - when (isJust stgtMode) $ setTgtId $ blid pbody + case stgtMode of + Nothing -> return () + Just _ -> + modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode $ blid pbody} -- Inform about items, etc. - lookMsg <- lookAt False True (bpos pbody) actor "" + lookMsg <- lookAt False "" True (bpos pbody) actor "" msgAdd lookMsg - -- Don't continue an old run, if any. - stopRunning return True -stopRunning :: MonadClient m => m () -stopRunning = modifyClient (\ cli -> cli { srunning = Nothing }) - -- * MemberBack -- | Switches current member to the previous in the whole dungeon, wrapping. -memberBackHuman :: (MonadClientAbort m, MonadClientUI m) => m () +memberBackHuman :: MonadClientUI m => m Slideshow memberBackHuman = do + side <- getsClient sside + fact <- getsState $ (EM.! side) . sfactionD leader <- getLeaderUI hs <- partyAfterLeader leader case reverse hs of - [] -> abortWith "No other member in the party." + _ | isSpawnFact fact -> failWith "spawners cannot manually change leaders" + [] -> failWith "No other member in the party." (np, b) : _ -> do - success <- selectLeader np + success <- pickLeader np assert (success `blame` "same leader" `twith` (leader, np, b)) skip + return mempty -- * Inventory @@ -287,107 +171,482 @@ -- announcing that) and show the inventory of the new leader (unless -- we have just a single inventory in the future). -- | Display inventory -inventoryHuman :: (MonadClientAbort m, MonadClientUI m) - => WriterT Slideshow m () +inventoryHuman :: MonadClientUI m => m Slideshow inventoryHuman = do leader <- getLeaderUI subject <- partAidLeader leader bag <- getsState $ getActorBag leader - inv <- getsState $ getActorInv leader + invRaw <- getsState $ getActorInv leader if EM.null bag - then abortWith $ makeSentence + then promptToSlideshow $ makeSentence [ MU.SubjectVerbSg subject "be" , "not carrying anything" ] else do let blurb = makePhrase [MU.Capitalize $ MU.SubjectVerbSg subject "be carrying:"] + inv = EM.filter (`EM.member` bag) invRaw io <- itemOverlay bag inv - slides <- overlayToSlideshow blurb io - tell slides + overlayToSlideshow blurb io --- * TgtFloor +-- * SelectActor --- | Start floor targeting mode or reset the cursor position to the leader. --- Note that the origin of a command (the hero that performs it) is unaffected --- by targeting. For example, not the targeted door, but one adjacent --- to the selected hero is closed by him. -tgtFloorLeader :: MonadClientUI m => TgtMode -> WriterT Slideshow m () -tgtFloorLeader stgtModeNew = do +-- TODO: make the message (and for selectNoneHuman, pickLeader, etc.) +-- optional, since they have a clear representation in the UI elsewhere. +selectActorHuman ::MonadClientUI m => m Slideshow +selectActorHuman = do + mleader <- getsClient _sleader + case mleader of + Nothing -> failWith "no leader picked, cannot select" + Just leader -> do + body <- getsState $ getActorBody leader + wasMemeber <- getsClient $ ES.member leader . sselected + let upd = if wasMemeber + then ES.delete leader -- already selected, deselect instead + else ES.insert leader + modifyClient $ \cli -> cli {sselected = upd $ sselected cli} + let subject = partActor body + msgAdd $ makeSentence [subject, if wasMemeber + then "deselected" + else "selected"] + return mempty + +-- * SelectNone + +selectNoneHuman :: (MonadClientUI m, MonadClient m) => m () +selectNoneHuman = do + side <- getsClient sside + lidV <- viewedLevel + oursAssocs <- getsState $ actorNotProjAssocs (== side) lidV + let ours = ES.fromList $ map fst oursAssocs + oldSel <- getsClient sselected + let wasNone = ES.null $ ES.intersection ours oldSel + upd = if wasNone + then ES.union -- already all deselected; select all instead + else ES.difference + modifyClient $ \cli -> cli {sselected = upd (sselected cli) ours} + let subject = "all party members on the level" + msgAdd $ makeSentence [subject, if wasNone + then "selected" + else "deselected"] + +-- * Clear + +-- | Clear current messages, show the next screen if any. +clearHuman :: Monad m => m () +clearHuman = return () + +-- * Repeat + +-- Note that walk followed by repeat should not be equivalent to run, +-- because the player can really use a command that does not stop +-- at terrain change or when walking over items. +repeatHuman :: MonadClient m => Int -> m () +repeatHuman n = do + (_, seqPrevious, k) <- getsClient slastRecord + let macro = concat $ replicate n $ reverse seqPrevious + modifyClient $ \cli -> cli {slastPlay = macro ++ slastPlay cli} + let slastRecord = ([], [], if k == 0 then 0 else maxK) + modifyClient $ \cli -> cli {slastRecord} + +maxK :: Int +maxK = 100 + +-- * Record + +recordHuman :: MonadClientUI m => m Slideshow +recordHuman = do + modifyClient $ \cli -> cli {slastKey = Nothing} + (_seqCurrent, seqPrevious, k) <- getsClient slastRecord + case k of + 0 -> do + let slastRecord = ([], [], maxK) + modifyClient $ \cli -> cli {slastRecord} + promptToSlideshow $ "Macro will be recorded for up to" + <+> tshow maxK <+> "steps." + _ -> do + let slastRecord = (seqPrevious, [], 0) + modifyClient $ \cli -> cli {slastRecord} + promptToSlideshow $ "Macro recording interrupted after" + <+> tshow (maxK - k - 1) <+> "steps." + +-- * History + +historyHuman :: MonadClientUI m => m Slideshow +historyHuman = do + history <- getsClient shistory + arena <- getArenaUI + local <- getsState $ getLocalTime arena + global <- getsState stime + let msg = makeSentence + [ "You survived for" + , MU.CarWs (global `timeFit` timeTurn) "half-second turn" + , "(this level:" + , MU.Text (tshow (local `timeFit` timeTurn)) MU.:> ")" ] + <+> "Past messages:" + overlayToBlankSlideshow msg $ renderHistory history + +-- * MarkVision, MarkSmell, MarkSuspect + +markVisionHuman :: MonadClientUI m => m () +markVisionHuman = do + modifyClient toggleMarkVision + cur <- getsClient smarkVision + msgAdd $ "Visible area display toggled" <+> if cur then "on." else "off." + +markSmellHuman :: MonadClientUI m => m () +markSmellHuman = do + modifyClient toggleMarkSmell + cur <- getsClient smarkSmell + msgAdd $ "Smell display toggled" <+> if cur then "on." else "off." + +markSuspectHuman :: MonadClientUI m => m () +markSuspectHuman = do + -- BFS takes suspect tiles into account depending on @smarkSuspect@, + -- so we need to invalidate the BFS data caches. + modifyClient $ \cli -> cli {sbfsD = EM.empty} + modifyClient toggleMarkSuspect + cur <- getsClient smarkSuspect + msgAdd $ "Suspect terrain display toggled" <+> if cur then "on." else "off." + +-- * Help + +-- | Display command help. +helpHuman :: MonadClientUI m => m Slideshow +helpHuman = do + keyb <- askBinding + return $! keyHelp keyb + +-- * MainMenu + +-- TODO: merge with the help screens better +-- | Display the main menu. +mainMenuHuman :: MonadClientUI m => m Slideshow +mainMenuHuman = do + Kind.COps{corule} <- getsState scops + Binding{brevMap, bcmdList} <- askBinding + scurDifficulty <- getsClient scurDifficulty + DebugModeCli{sdifficultyCli} <- getsClient sdebugCli + let stripFrame t = map (T.tail . T.init) $ tail . init $ T.lines t + pasteVersion art = + let pathsVersion = rpathsVersion $ Kind.stdRuleset corule + version = " Version " ++ showVersion pathsVersion + ++ " (frontend: " ++ frontendName + ++ ", engine: LambdaHack " ++ showVersion Self.version + ++ ") " + versionLen = length version + in init art ++ [take (80 - versionLen) (last art) ++ version] + kds = -- key-description pairs + let showKD cmd km = (K.showKM km, HumanCmd.cmdDescription cmd) + revLookup cmd = maybe ("", "") (showKD cmd) $ M.lookup cmd brevMap + cmds = [ (K.showKM km, desc) + | (km, (desc, HumanCmd.CmdMenu, cmd)) <- bcmdList, + cmd /= HumanCmd.GameDifficultyCycle ] + in [ (fst (revLookup HumanCmd.Cancel), "back to playing") + , (fst (revLookup HumanCmd.Accept), "see more help") ] + ++ cmds + ++ [ (fst ( revLookup HumanCmd.GameDifficultyCycle) + , "next game difficulty" + <+> tshow (5 - sdifficultyCli) + <+> "(current" + <+> tshow (5 - scurDifficulty) <> ")" ) ] + bindingLen = 25 + bindings = -- key bindings to display + let fmt (k, d) = T.justifyLeft bindingLen ' ' + $ T.justifyLeft 7 ' ' k <> " " <> d + in map fmt kds + overwrite = -- overwrite the art with key bindings + let over [] line = ([], T.pack line) + over bs@(binding : bsRest) line = + let (prefix, lineRest) = break (=='{') line + (braces, suffix) = span (=='{') lineRest + in if length braces == 25 + then (bsRest, T.pack prefix <> binding + <> T.drop (T.length binding - bindingLen) + (T.pack suffix)) + else (bs, T.pack line) + in snd . mapAccumL over bindings + mainMenuArt = rmainMenuArt $ Kind.stdRuleset corule + menuOverlay = -- TODO: switch to Text and use T.justifyLeft + overwrite $ pasteVersion $ map T.unpack $ stripFrame mainMenuArt + case menuOverlay of + [] -> assert `failure` "empty Main Menu overlay" `twith` mainMenuArt + hd : tl -> overlayToBlankSlideshow hd (toOverlay tl) + -- TODO: keys don't work if tl/=[] + +-- * Macro + +macroHuman :: MonadClient m => [String] -> m () +macroHuman kms = + modifyClient $ \cli -> cli {slastPlay = map K.mkKM kms ++ slastPlay cli} + +-- * MoveCursor + +moveCursorHuman :: MonadClientUI m => Vector -> Int -> m Slideshow +moveCursorHuman dir n = do leader <- getLeaderUI - ppos <- getsState (bpos . getActorBody leader) - target <- getsClient $ getTarget leader stgtMode <- getsClient stgtMode - let tgt = case target of - Just (TEnemy _ _) -> Nothing -- forget enemy target, keep the cursor - _ | isJust stgtMode -> - Just (TPos ppos) -- double key press: reset cursor - t -> t -- keep the target from previous targeting session - -- Register that we want to target only positions. - modifyClient $ updateTarget leader (const tgt) - setCursor stgtModeNew + let lidV = maybe (assert `failure` leader) tgtLevelId stgtMode + Level{lxsize, lysize} <- getLevel lidV + lpos <- getsState $ bpos . getActorBody leader + scursor <- getsClient scursor + cursorPos <- cursorToPos + let cpos = fromMaybe lpos cursorPos + shiftB pos = shiftBounded lxsize lysize pos dir + newPos = iterate shiftB cpos !! n + if newPos == cpos then failWith "never mind" + else do + let tgt = case scursor of + TVector{} -> TVector $ displacement lpos newPos + _ -> TPoint lidV newPos + modifyClient $ \cli -> cli {scursor = tgt} + doLook --- | Set, activate and display cursor information. -setCursor :: MonadClientUI m => TgtMode -> WriterT Slideshow m () -setCursor stgtModeNew = do - stgtModeOld <- getsClient stgtMode - scursorOld <- getsClient scursor - sepsOld <- getsClient seps - scursor <- targetToPos - let seps = if scursor == scursorOld then sepsOld else 0 - stgtMode = if isNothing stgtModeOld - then Just stgtModeNew - else stgtModeOld - modifyClient $ \cli2 -> cli2 {scursor, seps, stgtMode} +-- TODO: probably move somewhere (Level?) +-- | Produces a textual description of the terrain and items at an already +-- explored position. Mute for unknown positions. +-- The detailed variant is for use in the targeting mode. +lookAt :: MonadClientUI m + => Bool -- ^ detailed? + -> Text -- ^ how to start tile description + -> Bool -- ^ can be seen right now? + -> Point -- ^ position to describe + -> ActorId -- ^ the actor that looks + -> Text -- ^ an extra sentence to print + -> m Text +lookAt detailed tilePrefix canSee pos aid msg = do + Kind.COps{coitem, cotile=cotile@Kind.Ops{okind}} <- getsState scops + lidV <- viewedLevel + lvl <- getLevel lidV + subject <- partAidLeader aid + s <- getState + let is = lvl `atI` pos + verb = MU.Text $ if canSee then "notice" else "remember" + disco <- getsClient sdisco + let nWs (iid, k) = partItemWs coitem disco k (getItemBody iid s) + isd = case detailed of + _ | EM.size is == 0 -> "" + _ | EM.size is <= 2 -> + makeSentence [ MU.SubjectVerbSg subject verb + , MU.WWandW $ map nWs $ EM.assocs is] + True -> "Objects:" + _ -> "Objects here." + tile = lvl `at` pos + obscured | tile /= hideTile cotile lvl pos = "partially obscured" + | otherwise = "" + tileText = obscured <+> tname (okind tile) + tilePart | T.null tilePrefix = MU.Text tileText + | otherwise = MU.AW $ MU.Text tileText + tileDesc = [MU.Text tilePrefix, tilePart] + if not (null (Tile.causeEffects cotile tile)) then + return $! makeSentence ("activable:" : tileDesc) + <+> msg <+> isd + else if detailed then + return $! makeSentence tileDesc + <+> msg <+> isd + else return $! msg <+> isd + +-- | Perform look around in the current position of the cursor. +-- Assumes targeting mode and so assumes that a leader is picked. +doLook :: MonadClientUI m => m Slideshow +doLook = do + leader <- getLeaderUI + stgtMode <- getsClient stgtMode + let lidV = maybe (assert `failure` leader) tgtLevelId stgtMode + lvl <- getLevel lidV + cursorPos <- cursorToPos + per <- getPerFid lidV + b <- getsState $ getActorBody leader + let p = fromMaybe (bpos b) cursorPos + canSee = ES.member p (totalVisible per) + inhabitants <- if canSee + then getsState $ posToActors p lidV + else return [] + aims <- actorAimsPos leader p + let enemyMsg = case inhabitants of + [] -> "" + _ -> -- Even if it's the leader, give his proper name, not 'you'. + let subjects = map (partActor . snd . fst) inhabitants + subject = MU.WWandW subjects + verb = "be here" + in makeSentence [MU.SubjectVerbSg subject verb] + vis | not canSee = "you cannot see" + | not aims = "you cannot penetrate" + | otherwise = "you see" + -- Show general info about current position. + lookMsg <- lookAt True vis canSee p leader enemyMsg + modifyClient $ \cli -> cli {slastKey = Nothing} + -- Check if there's something lying around at current position. + let is = lvl `atI` p + if EM.size is <= 2 then + promptToSlideshow lookMsg + else do + io <- floorItemOverlay is + overlayToSlideshow lookMsg io + +-- | Create a list of item names. +floorItemOverlay :: MonadClient m => ItemBag -> m Overlay +floorItemOverlay bag = do + Kind.COps{coitem} <- getsState scops + s <- getState + disco <- getsClient sdisco + let is = zip (EM.assocs bag) (allLetters ++ repeat (InvChar ' ')) + pr ((iid, k), l) = + makePhrase [ letterLabel l + , partItemWs coitem disco k (getItemBody iid s) ] + <> " " + return $! toOverlay $ map pr is + +-- | Create a list of item names. +itemOverlay :: MonadClient m => ItemBag -> ItemInv -> m Overlay +itemOverlay bag inv = do + Kind.COps{coitem} <- getsState scops + s <- getState + disco <- getsClient sdisco + let pr (l, iid) = + makePhrase [ letterLabel l + , partItemWs coitem disco (bag EM.! iid) + (getItemBody iid s) ] + <> " " + return $! toOverlay $ map pr $ EM.assocs inv + +-- * TgtFloor + +-- | Cycle targeting mode. Do not change position of the cursor, +-- switch among things at that position. +tgtFloorHuman :: MonadClientUI m => m Slideshow +tgtFloorHuman = do + lidV <- viewedLevel + leader <- getLeaderUI + lpos <- getsState $ bpos . getActorBody leader + cursorPos <- cursorToPos + scursor <- getsClient scursor + stgtMode <- getsClient stgtMode + side <- getsClient sside + fact <- getsState $ (EM.! side) . sfactionD + bfs <- getCacheBfs leader + bsAll <- getsState $ actorAssocs (const True) lidV + let cursor = fromMaybe lpos cursorPos + tgt = case scursor of + _ | isNothing stgtMode -> -- first key press: keep target + scursor + TEnemy a False -> TEnemy a True + TEnemy{} -> TPoint lidV cursor + TEnemyPos{} -> TPoint lidV cursor + TPoint{} -> TVector $ displacement lpos cursor + TVector{} -> + let isEnemy b = isAtWar fact (bfid b) + && not (bproj b) + && posAimsPos bfs lpos (bpos b) + -- For projectiles, we pick here the first that would be picked + -- by '*', so that all other projectiles on the tile come next, + -- without any intervening actors from other tiles. + in case find (\(_, m) -> Just (bpos m) == cursorPos) bsAll of + Just (im, m) | isEnemy m -> TEnemy im False + Just (im, _) -> TEnemy im True + Nothing -> TPoint lidV cursor + modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV} doLook -- * TgtEnemy --- | Start the enemy targeting mode. Cycle between enemy targets. -tgtEnemyLeader :: MonadClientUI m => TgtMode -> WriterT Slideshow m () -tgtEnemyLeader stgtModeNew = do +tgtEnemyHuman :: MonadClientUI m => m Slideshow +tgtEnemyHuman = do + lidV <- viewedLevel leader <- getLeaderUI - ppos <- getsState (bpos . getActorBody leader) - (lid, Level{lxsize}) <- viewedLevel - per <- getPerFid lid - target <- getsClient $ getTarget leader + lpos <- getsState $ bpos . getActorBody leader + cursorPos <- cursorToPos + scursor <- getsClient scursor stgtMode <- getsClient stgtMode side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD - bs <- getsState $ actorNotProjAssocs (isAtWar fact) lid - let ordPos (_, b) = (chessDist lxsize ppos $ bpos b, bpos b) - dbs = sortBy (comparing ordPos) bs - (lt, gt) = case target of - Just (TEnemy n _) | isJust stgtMode -> -- pick next enemy - let i = fromMaybe (-1) $ findIndex ((== n) . fst) dbs - in splitAt (i + 1) dbs - Just (TEnemy n _) -> -- try to retarget the old enemy - let i = fromMaybe (-1) $ findIndex ((== n) . fst) dbs - in splitAt i dbs - _ -> (dbs, []) -- target first enemy (e.g., number 0) + bfs <- getCacheBfs leader + bsAll <- getsState $ actorAssocs (const True) lidV + let ordPos (_, b) = (chessDist lpos $ bpos b, bpos b) + dbs = sortBy (comparing ordPos) bsAll + pickUnderCursor = -- switch to the enemy under cursor, if any + let i = fromMaybe (-1) + $ findIndex ((== cursorPos) . Just . bpos . snd) dbs + in splitAt i dbs + (permitAnyActor, (lt, gt)) = case scursor of + TEnemy a permit | isJust stgtMode -> -- pick next enemy + let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs + in (permit, splitAt (i + 1) dbs) + TEnemy a permit -> -- first key press, retarget old enemy + let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs + in (permit, splitAt i dbs) + TEnemyPos _ _ _ permit -> (permit, pickUnderCursor) + _ -> (False, pickUnderCursor) -- the sensible default is only-foes gtlt = gt ++ lt - seen (_, b) = - let mpos = bpos b -- it is remembered by faction - in actorSeesPos per leader mpos -- is it visible by actor? - lf = filter seen gtlt - tgt = case lf of - [] -> target -- no enemies in sight, stick to last target - (na, nm) : _ -> Just (TEnemy na (bpos nm)) -- pick the next + isEnemy b = isAtWar fact (bfid b) + && not (bproj b) + && posAimsPos bfs lpos (bpos b) + lf = filter (isEnemy . snd) gtlt + tgt | permitAnyActor = case gtlt of + (a, _) : _ -> TEnemy a True + [] -> scursor -- no actors in sight, stick to last target + | otherwise = case lf of + (a, _) : _ -> TEnemy a False + [] -> scursor -- no seen foes in sight, stick to last target -- Register the chosen enemy, to pick another on next invocation. - modifyClient $ updateTarget leader (const tgt) - setCursor stgtModeNew + modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV} + doLook +-- * TgtUnknown + +tgtUnknownHuman :: MonadClientUI m => m Slideshow +tgtUnknownHuman = do + leader <- getLeaderUI + b <- getsState $ getActorBody leader + mpos <- closestUnknown leader + case mpos of + Nothing -> failWith "no more unknown spots left" + Just p -> do + let tgt = TPoint (blid b) p + modifyClient $ \cli -> cli {scursor = tgt} + return mempty + +-- * TgtItem + +tgtItemHuman :: MonadClientUI m => m Slideshow +tgtItemHuman = do + leader <- getLeaderUI + b <- getsState $ getActorBody leader + items <- closestItems leader + case items of + [] -> failWith "no more items remembered or visible" + (_, (p, _)) : _ -> do + let tgt = TPoint (blid b) p + modifyClient $ \cli -> cli {scursor = tgt} + return mempty + +-- * TgtStair + +tgtStairHuman :: MonadClientUI m => Bool -> m Slideshow +tgtStairHuman up = do + leader <- getLeaderUI + b <- getsState $ getActorBody leader + stairs <- closestTriggers (Just up) False leader + case stairs of + [] -> failWith $ "no stairs" + <+> if up then "up" else "down" + p : _ -> do + let tgt = TPoint (blid b) p + modifyClient $ \cli -> cli {scursor = tgt} + return mempty + -- * TgtAscend -- | Change the displayed level in targeting mode to (at most) -- k levels shallower. Enters targeting mode, if not already in one. -tgtAscendHuman :: (MonadClientAbort m, MonadClientUI m) - => Int -> WriterT Slideshow m () +tgtAscendHuman :: MonadClientUI m => Int -> m Slideshow tgtAscendHuman k = do - Kind.COps{cotile} <- getsState scops + Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops dungeon <- getsState sdungeon - cursor <- getsClient scursor - (tgtId, lvl) <- viewedLevel - let rightStairs = case cursor of + scursorOld <- getsClient scursor + cursorPos <- cursorToPos + lidV <- viewedLevel + lvl <- getLevel lidV + let rightStairs = case cursorPos of Nothing -> Nothing Just cpos -> let tile = lvl `at` cpos @@ -396,213 +655,104 @@ else Nothing case rightStairs of Just cpos -> do -- stairs, in the right direction - (nln, npos) <- getsState $ whereTo tgtId cpos k - assert (nln /= tgtId `blame` "stairs looped" `twith` nln) skip + (nln, npos) <- getsState $ whereTo lidV cpos k . sdungeon + assert (nln /= lidV `blame` "stairs looped" `twith` nln) skip -- Do not freely reveal the other end of the stairs. - let scursor = - if Tile.hasFeature cotile F.Exit (lvl `at` npos) - then Just npos -- already know as an exit, focus on it - else cursor -- unknown, do not reveal - modifyClient $ \cli -> cli {scursor} - setTgtId nln + let ascDesc (F.Cause (Effect.Ascend _)) = True + ascDesc _ = False + scursor = + if any ascDesc $ tfeature $ okind (lvl `at` npos) + then TPoint nln npos -- already known as an exit, focus on it + else scursorOld -- unknown, do not reveal + modifyClient $ \cli -> cli {scursor, stgtMode = Just (TgtMode nln)} + doLook Nothing -> -- no stairs in the right direction - case ascendInBranch dungeon tgtId k of - [] -> abortWith "no more levels in this direction" - nln : _ -> setTgtId nln - doLook - -setTgtId :: MonadClient m => LevelId -> m () -setTgtId nln = do - stgtMode <- getsClient stgtMode - case stgtMode of - Just (TgtAuto _) -> - modifyClient $ \cli -> cli {stgtMode = Just (TgtAuto nln)} - _ -> - modifyClient $ \cli -> cli {stgtMode = Just (TgtExplicit nln)} + case ascendInBranch dungeon k lidV of + [] -> failWith "no more levels in this direction" + nln : _ -> do + modifyClient $ \cli -> cli {stgtMode = Just (TgtMode nln)} + doLook -- * EpsIncr -- | Tweak the @eps@ parameter of the targeting digital line. -epsIncrHuman :: MonadClientAbort m => Bool -> m () +epsIncrHuman :: MonadClientUI m => Bool -> m Slideshow epsIncrHuman b = do stgtMode <- getsClient stgtMode if isJust stgtMode - then modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else -1} - else neverMind True -- no visual feedback, so no sense + then do + modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else -1} + return mempty + else failWith "never mind" -- no visual feedback, so no sense +-- * TgtClear + +tgtClearHuman :: MonadClient m => m () +tgtClearHuman = do + mleader <- getsClient _sleader + case mleader of + Nothing -> return () + Just leader -> do + tgt <- getsClient $ getTarget leader + case tgt of + Just _ -> modifyClient $ updateTarget leader (const Nothing) + Nothing -> do + scursorOld <- getsClient scursor + b <- getsState $ getActorBody leader + let scursor = case scursorOld of + TEnemy _ permit -> TEnemy leader permit + TEnemyPos _ _ _ permit -> TEnemy leader permit + TPoint{} -> TPoint (blid b) (bpos b) + TVector{} -> TVector (Vector 0 0) + modifyClient $ \cli -> cli {scursor} + -- * Cancel -- | Cancel something, e.g., targeting mode, resetting the cursor -- to the position of the leader. Chosen target is not invalidated. -cancelHuman :: MonadClientUI m - => WriterT Slideshow m () -> WriterT Slideshow m () +cancelHuman :: MonadClientUI m => m Slideshow -> m Slideshow cancelHuman h = do stgtMode <- getsClient stgtMode if isJust stgtMode - then endTargeting False + then targetReject else h -- nothing to cancel right now, treat this as a command invocation --- TODO: merge with the help screens better --- | Display the main menu. -displayMainMenu :: MonadClientUI m => WriterT Slideshow m () -displayMainMenu = do - Kind.COps{corule} <- getsState scops - Binding{krevMap} <- askBinding - let stripFrame t = map (T.tail . T.init) $ tail . init $ T.lines t - pasteVersion art = - let pathsVersion = rpathsVersion $ Kind.stdRuleset corule - version = " Version " ++ showVersion pathsVersion - ++ " (frontend: " ++ frontendName - ++ ", engine: LambdaHack " ++ showVersion Self.version - ++ ") " - versionLen = length version - in init art ++ [take (80 - versionLen) (last art) ++ version] - kds = -- key-description pairs - let showKD cmd km = (K.showKM km, HumanCmd.cmdDescription cmd) - revLookup cmd = maybe ("", "") (showKD cmd) $ M.lookup cmd krevMap - cmds = [ HumanCmd.GameExit - , HumanCmd.GameRestart "campaign" - , HumanCmd.GameRestart "skirmish" - , HumanCmd.GameRestart "PvP" - , HumanCmd.GameRestart "Coop" - , HumanCmd.GameRestart "defense" - ] - in [ (fst (revLookup HumanCmd.Cancel), "back to playing") - , (fst (revLookup HumanCmd.Accept), "see more help") ] - ++ map revLookup cmds - bindings = -- key bindings to display - let bindingLen = 25 - fmt (k, d) = - let gapLen = (8 - T.length k) `max` 1 - padLen = bindingLen - T.length k - gapLen - T.length d - in k <> T.replicate gapLen " " <> d <> T.replicate padLen " " - in map fmt kds - overwrite = -- overwrite the art with key bindings - let over [] line = ([], T.pack line) - over bs@(binding : bsRest) line = - let (prefix, lineRest) = break (=='{') line - (braces, suffix) = span (=='{') lineRest - in if length braces == 25 - then (bsRest, T.pack prefix <> binding <> T.pack suffix) - else (bs, T.pack line) - in snd . mapAccumL over bindings - mainMenuArt = rmainMenuArt $ Kind.stdRuleset corule - menuOverlay = -- TODO: switch to Text and use T.justifyLeft - overwrite $ pasteVersion $ map T.unpack $ stripFrame mainMenuArt - case menuOverlay of - [] -> assert `failure` "empty Main Menu overlay" `twith` mainMenuArt - hd : tl -> do - slides <- overlayToSlideshow hd tl -- TODO: keys don't work if tl/=[] - tell slides +-- | End targeting mode, rejecting the current position. +targetReject :: MonadClientUI m => m Slideshow +targetReject = do + modifyClient $ \cli -> cli {stgtMode = Nothing} + failWith "targeting canceled" -- * Accept -- | Accept something, e.g., targeting mode, keeping cursor where it was. -- Or perform the default action, if nothing needs accepting. -acceptHuman :: MonadClientUI m - => WriterT Slideshow m () -> WriterT Slideshow m () +acceptHuman :: MonadClientUI m => m Slideshow -> m Slideshow acceptHuman h = do stgtMode <- getsClient stgtMode if isJust stgtMode - then endTargeting True + then do + targetAccept + return mempty else h -- nothing to accept right now, treat this as a command invocation --- | End targeting mode, accepting the current position or not. -endTargeting :: MonadClientUI m => Bool -> m () -endTargeting accept = do - when accept $ do - leader <- getLeaderUI - target <- getsClient $ getTarget leader - scursor <- getsClient scursor - (lid, _) <- viewedLevel - side <- getsClient sside - fact <- getsState $ (EM.! side) . sfactionD - bs <- getsState $ actorNotProjAssocs (isAtWar fact) lid - case target of - Just TEnemy{} -> - -- If in enemy targeting mode, switch to the enemy under - -- the current cursor position, if any. - case find (\ (_im, m) -> Just (bpos m) == scursor) bs of - Just (im, m) -> - let tgt = Just $ TEnemy im (bpos m) - in modifyClient $ updateTarget leader (const tgt) - Nothing -> return () - _ -> case scursor of - Nothing -> return () - Just cpos -> - modifyClient $ updateTarget leader (const $ Just $ TPos cpos) - if accept - then endTargetingMsg - -- TODO: do not save to history: - else msgAdd "targeting canceled" - modifyClient $ \cli -> cli { stgtMode = Nothing } +-- | End targeting mode, accepting the current position. +targetAccept :: MonadClientUI m => m () +targetAccept = do + endTargeting + endTargetingMsg + modifyClient $ \cli -> cli {stgtMode = Nothing} +-- | End targeting mode, accepting the current position. +endTargeting :: MonadClientUI m => m () +endTargeting = do + leader <- getLeaderUI + scursor <- getsClient scursor + modifyClient $ updateTarget leader $ const $ Just scursor + endTargetingMsg :: MonadClientUI m => m () endTargetingMsg = do leader <- getLeaderUI - pbody <- getsState $ getActorBody leader - target <- getsClient $ getTarget leader - s <- getState - Level{lxsize} <- cursorLevel - let targetMsg = case target of - Just (TEnemy a _ll) -> - if memActor a (blid pbody) s - -- Never equal to leader, hence @partActor@. - then partActor $ getActorBody a s - else "a fear of the past" - Just (TPos tpos) -> - MU.Text $ "position" <+> showPoint lxsize tpos - Nothing -> "current cursor position continuously" + targetMsg <- targetDescLeader leader subject <- partAidLeader leader - msgAdd $ makeSentence [MU.SubjectVerbSg subject "target", targetMsg] - --- * Clear - --- | Clear current messages, show the next screen if any. -clearHuman :: Monad m => m () -clearHuman = return () - --- * History - -historyHuman :: MonadClientUI m => WriterT Slideshow m () -historyHuman = do - history <- getsClient shistory - arena <- getArenaUI - local <- getsState $ getLocalTime arena - global <- getsState stime - let msg = makeSentence - [ "You survived for" - , MU.CarWs (global `timeFit` timeTurn) "half-second turn" - , "(this level:" - , MU.Text (showT (local `timeFit` timeTurn)) MU.:> ")" ] - <+> "Past messages:" - slides <- overlayToSlideshow msg $ renderHistory history - tell slides - --- * MarkVision, MarkSmell, MarkSuspect - -humanMarkVision :: MonadClientUI m => m () -humanMarkVision = do - modifyClient toggleMarkVision - cur <- getsClient smarkVision - msgAdd $ "Visible area display toggled" <+> if cur then "on." else "off." - -humanMarkSmell :: MonadClientUI m => m () -humanMarkSmell = do - modifyClient toggleMarkSmell - cur <- getsClient smarkSmell - msgAdd $ "Smell display toggled" <+> if cur then "on." else "off." - -humanMarkSuspect :: MonadClientUI m => m () -humanMarkSuspect = do - modifyClient toggleMarkSuspect - cur <- getsClient smarkSuspect - msgAdd $ "Suspect terrain display toggled" <+> if cur then "on." else "off." - --- * Help - --- | Display command help. -helpHuman :: MonadClientUI m => WriterT Slideshow m () -helpHuman = do - keyb <- askBinding - tell $ keyHelp keyb + msgAdd $ makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg] diff --git a/Game/LambdaHack/Client/HumanSem.hs b/Game/LambdaHack/Client/HumanSem.hs --- a/Game/LambdaHack/Client/HumanSem.hs +++ b/Game/LambdaHack/Client/HumanSem.hs @@ -3,137 +3,79 @@ ( cmdHumanSem ) where -import Control.Monad -import Control.Monad.Writer.Strict (WriterT) -import Data.Maybe +import Data.Monoid -import Control.Exception.Assert.Sugar import Game.LambdaHack.Client.Action -import Game.LambdaHack.Client.HumanCmd import Game.LambdaHack.Client.HumanGlobal import Game.LambdaHack.Client.HumanLocal -import Game.LambdaHack.Client.State -import Game.LambdaHack.Common.Action -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Msg +import Game.LambdaHack.Common.HumanCmd import Game.LambdaHack.Common.ServerCmd -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Common.VectorXY -- | The semantics of human player commands in terms of the @Action@ monad. -- Decides if the action takes time and what action to perform. --- Time cosuming commands are marked as such in help and cannot be +-- Some time cosuming commands are enabled in targeting mode, but cannot be -- invoked in targeting mode on a remote level (level different than --- the level of the selected hero). -cmdHumanSem :: (MonadClientAbort m, MonadClientUI m) - => HumanCmd -> WriterT Slideshow m (Maybe CmdSer) +-- the level of the leader). +cmdHumanSem :: MonadClientUI m => HumanCmd -> m (SlideOrCmd CmdSer) cmdHumanSem cmd = do - arena <- getArenaUI - when (noRemoteHumanCmd cmd) $ checkCursor arena - cmdAction cmd + if noRemoteHumanCmd cmd then do + -- If in targeting mode, check if the current level is the same + -- as player level and refuse performing the action otherwise. + arena <- getArenaUI + lidV <- viewedLevel + if (arena /= lidV) then + failWith $ "command disabled on a remote level, press ESC to switch back" + else cmdAction cmd + else cmdAction cmd --- | The basic action for a command and whether it takes time. -cmdAction :: (MonadClientAbort m, MonadClientUI m) - => HumanCmd -> WriterT Slideshow m (Maybe CmdSer) +-- | Compute the basic action for a command and mark whether it takes time. +cmdAction :: MonadClientUI m => HumanCmd -> m (SlideOrCmd CmdSer) cmdAction cmd = case cmd of - Move v -> moveRunHuman False v - Run v -> moveRunHuman True v - Wait -> fmap (Just . TakeTimeSer) waitHuman - Pickup -> fmap (Just . TakeTimeSer) pickupHuman - Drop -> fmap (Just . TakeTimeSer) dropHuman - Project ts -> projectHuman ts - Apply ts -> fmap (Just . TakeTimeSer) $ applyHuman ts - AlterDir ts -> fmap (Just . TakeTimeSer) $ alterDirHuman ts - TriggerTile ts -> fmap (Just . TakeTimeSer) $ triggerTileHuman ts - - GameRestart t -> fmap Just $ gameRestartHuman t - GameExit -> fmap Just gameExitHuman - GameSave -> fmap Just gameSaveHuman - - SelectHero k -> selectHeroHuman k >> return Nothing - MemberCycle -> memberCycleHuman >> return Nothing - MemberBack -> memberBackHuman >> return Nothing - Inventory -> inventoryHuman >> return Nothing - TgtFloor -> tgtFloorHuman - TgtEnemy -> tgtEnemyHuman - TgtAscend k -> tgtAscendHuman k >> return Nothing - EpsIncr b -> epsIncrHuman b >> return Nothing - Cancel -> cancelHuman displayMainMenu >> return Nothing - Accept -> acceptHuman helpHuman >> return Nothing - Clear -> clearHuman >> return Nothing - History -> historyHuman >> return Nothing - MarkVision -> humanMarkVision >> return Nothing - MarkSmell -> humanMarkSmell >> return Nothing - MarkSuspect -> humanMarkSuspect >> return Nothing - Help -> displayMainMenu >> return Nothing - --- | If in targeting mode, check if the current level is the same --- as player level and refuse performing the action otherwise. -checkCursor :: (MonadClientAbort m, MonadClientUI m) => LevelId -> m () -checkCursor arena = do - (lid, _) <- viewedLevel - when (arena /= lid) $ - abortWith "[targeting] command disabled on a remote level, press ESC to switch back" + Move v -> fmap (fmap CmdTakeTimeSer) $ moveRunHuman False v + Run v -> fmap (fmap CmdTakeTimeSer) $ moveRunHuman True v + Wait -> fmap Right $ fmap CmdTakeTimeSer waitHuman + Pickup -> fmap (fmap CmdTakeTimeSer) pickupHuman + Drop -> fmap (fmap CmdTakeTimeSer) dropHuman + Project ts -> fmap (fmap CmdTakeTimeSer) $ projectHuman ts + Apply ts -> fmap (fmap CmdTakeTimeSer) $ applyHuman ts + AlterDir ts -> fmap (fmap CmdTakeTimeSer) $ alterDirHuman ts + TriggerTile ts -> fmap (fmap CmdTakeTimeSer) $ triggerTileHuman ts + StepToTarget -> fmap (fmap CmdTakeTimeSer) stepToTargetHuman + Resend -> fmap (fmap CmdTakeTimeSer) resendHuman -moveRunHuman :: (MonadClientAbort m, MonadClientUI m) - => Bool -> VectorXY -> WriterT Slideshow m (Maybe CmdSer) -moveRunHuman run v = do - tgtMode <- getsClient stgtMode - (arena, Level{lxsize}) <- viewedLevel - source <- getLeaderUI - sb <- getsState $ getActorBody source - let dir = toDir lxsize v - if isJust tgtMode then do - moveCursor dir (if run then 10 else 1) >> return Nothing - else do - let tpos = bpos sb `shift` dir - -- We start by checking actors at the the target position, - -- which gives a partial information (actors can be invisible), - -- as opposed to accessibility (and items) which are always accurate - -- (tiles can't be invisible). - tgt <- getsState $ posToActor tpos arena - case tgt of - Nothing -> do -- move or search or alter - when run $ modifyClient $ \cli -> cli {srunning = Just (dir, 1)} - fmap (Just . TakeTimeSer) $ moveRunAid source dir - -- When running, the invisible actor is hit (not displaced!), - -- so that running in the presence of roving invisible - -- actors is equivalent to moving (with visible actors - -- this is not a problem, since runnning stops early enough). - -- TODO: stop running at invisible actor - Just target | run -> - -- Displacing requires accessibility, but it's checked later on. - fmap (Just . TakeTimeSer) $ displaceAid source target - Just target -> do - tb <- getsState $ getActorBody target - -- We always see actors from our own faction. - if bfid tb == bfid sb && not (bproj tb) then do - -- Select adjacent actor by bumping into him. Takes no time. - success <- selectLeader target - assert (success `blame` "bump self" `twith` (source, target, tb)) skip - return Nothing - else - -- Attacking does not require full access, adjacency is enough. - fmap (Just . TakeTimeSer) $ meleeAid source target + GameRestart t -> gameRestartHuman t + GameExit -> gameExitHuman + GameSave -> fmap Right gameSaveHuman -projectHuman :: (MonadClientAbort m, MonadClientUI m) - => [Trigger] -> WriterT Slideshow m (Maybe CmdSer) -projectHuman ts = do - tgtLoc <- targetToPos - if isNothing tgtLoc - then retargetLeader >> return Nothing - else do - leader <- getLeaderUI - fmap (Just . TakeTimeSer) $ projectAid leader ts + GameDifficultyCycle -> addNoSlides gameDifficultyCycle + PickLeader k -> fmap Left $ pickLeaderHuman k + MemberCycle -> fmap Left memberCycleHuman + MemberBack -> fmap Left memberBackHuman + Inventory -> fmap Left inventoryHuman + SelectActor -> fmap Left selectActorHuman + SelectNone -> addNoSlides selectNoneHuman + Clear -> addNoSlides clearHuman + Repeat n -> addNoSlides $ repeatHuman n + Record -> fmap Left recordHuman + History -> fmap Left historyHuman + MarkVision -> addNoSlides markVisionHuman + MarkSmell -> addNoSlides markSmellHuman + MarkSuspect -> addNoSlides markSuspectHuman + Help -> fmap Left helpHuman + MainMenu -> fmap Left mainMenuHuman + Macro _ kms -> addNoSlides $ macroHuman kms -tgtFloorHuman :: MonadClientUI m => WriterT Slideshow m (Maybe CmdSer) -tgtFloorHuman = do - arena <- getArenaUI - tgtFloorLeader (TgtExplicit arena) >> return Nothing + MoveCursor v k -> fmap Left $ moveCursorHuman v k + TgtFloor -> fmap Left tgtFloorHuman + TgtEnemy -> fmap Left tgtEnemyHuman + TgtUnknown -> fmap Left tgtUnknownHuman + TgtItem -> fmap Left tgtItemHuman + TgtStair up -> fmap Left $ tgtStairHuman up + TgtAscend k -> fmap Left $ tgtAscendHuman k + EpsIncr b -> fmap Left $ epsIncrHuman b + TgtClear -> addNoSlides tgtClearHuman + Cancel -> fmap Left $ cancelHuman mainMenuHuman + Accept -> fmap Left $ acceptHuman helpHuman -tgtEnemyHuman :: MonadClientUI m => WriterT Slideshow m (Maybe CmdSer) -tgtEnemyHuman = do - arena <- getArenaUI - tgtEnemyLeader (TgtExplicit arena) >> return Nothing +addNoSlides :: Monad m => m () -> m (SlideOrCmd CmdSer) +addNoSlides cmdCli = cmdCli >> return (Left mempty) diff --git a/Game/LambdaHack/Client/LoopAction.hs b/Game/LambdaHack/Client/LoopAction.hs --- a/Game/LambdaHack/Client/LoopAction.hs +++ b/Game/LambdaHack/Client/LoopAction.hs @@ -3,6 +3,7 @@ -- moves turn by turn. module Game.LambdaHack.Client.LoopAction (loopAI, loopUI) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.Text as T @@ -16,20 +17,20 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.State import Game.LambdaHack.Content.RuleKind -import Control.Exception.Assert.Sugar initCli :: MonadClient m => DebugModeCli -> (State -> m ()) -> m Bool initCli sdebugCli putSt = do -- Warning: state and client state are invalid here, e.g., sdungeon -- and sper are empty. cops <- getsState scops + sconfigUI <- getsClient sconfigUI -- config from file, not savegame modifyClient $ \cli -> cli {sdebugCli} restored <- restoreGame case restored of Just (s, cli) | not $ snewGameCli sdebugCli -> do -- Restore the game. let sCops = updateCOps (const cops) s putSt sCops - putClient cli {sdebugCli} + putClient cli {sdebugCli, sconfigUI} return True _ -> -- First visit ever, use the initial state. return False @@ -43,19 +44,19 @@ cmd1 <- readServer case (restored, cmd1) of (True, CmdAtomicAI ResumeA{}) -> return () - (True, CmdAtomicAI RestartA{}) -> return () -- ignoring old savefile + (True, CmdAtomicAI RestartA{}) -> return () (False, CmdAtomicAI ResumeA{}) -> do removeServerSave error $ T.unpack $ - "Savefile of client" <+> showT side + "Savefile of client" <+> tshow side <+> "not usable. Removing server savefile. Please restart now." (False, CmdAtomicAI RestartA{}) -> return () _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1) cmdClientAISem cmd1 -- State and client state now valid. - debugPrint $ "AI client" <+> showT side <+> "started." + debugPrint $ "AI client" <+> tshow side <+> "started." loop - debugPrint $ "AI client" <+> showT side <+> "stopped." + debugPrint $ "AI client" <+> tshow side <+> "stopped." where loop = do cmd <- readServer @@ -84,7 +85,7 @@ (False, CmdAtomicUI ResumeA{}) -> do removeServerSave error $ T.unpack $ - "Savefile of client" <+> showT side + "Savefile of client" <+> tshow side <+> "not usable. Removing server savefile. Please restart now." (False, CmdAtomicUI RestartA{}) -> do let msg = "Welcome to" <+> title <> "!" @@ -92,9 +93,9 @@ msgAdd msg _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1) -- State and client state now valid. - debugPrint $ "UI client" <+> showT side <+> "started." + debugPrint $ "UI client" <+> tshow side <+> "started." loop - debugPrint $ "UI client" <+> showT side <+> "stopped." + debugPrint $ "UI client" <+> tshow side <+> "stopped." where loop = do cmd <- readServer diff --git a/Game/LambdaHack/Client/RunAction.hs b/Game/LambdaHack/Client/RunAction.hs --- a/Game/LambdaHack/Client/RunAction.hs +++ b/Game/LambdaHack/Client/RunAction.hs @@ -1,211 +1,276 @@ +{-# LANGUAGE RankNTypes #-} -- | Running and disturbance. +-- +-- The general rule is: whatever is behind you (and so ignored previously), +-- determines what you ignore moving forward. This is calcaulated +-- separately for the tiles to the left, to the right and in the middle +-- along the running direction. So, if you want to ignore something +-- start running when you stand on it (or to the right or left, respectively) +-- or by entering it (or passing to the right or left, respectively). +-- +-- Some things are never ignored, such as: enemies seen, imporant messages +-- heard, solid tiles and actors in the way. module Game.LambdaHack.Client.RunAction - ( continueRunDir + ( continueRun, moveRunAid ) where +import Control.Exception.Assert.Sugar +import Control.Monad import qualified Data.ByteString.Char8 as BS import qualified Data.EnumMap.Strict as EM -import qualified Data.EnumSet as ES -import qualified Data.List as L +import Data.Function +import Data.List import Data.Maybe -import Control.Exception.Assert.Sugar import Game.LambdaHack.Client.Action import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import qualified Game.LambdaHack.Common.Feature as F import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Msg -import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.PointXY +import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.TileKind --- | Start running in the given direction and with the given number --- of tiles already traversed (usually 0). The first turn of running --- succeeds much more often than subsequent turns, because most --- of the disturbances are ignored, since the player is aware of them --- and still explicitly requests a run. -canRun :: MonadClient m => ActorId -> (Vector, Int) -> m Bool -canRun leader (dir, dist) = do - cops <- getsState scops - b <- getsState $ getActorBody leader - lvl <- getLevel $ blid b - stgtMode <- getsClient stgtMode - assert (isNothing stgtMode `blame` "attempt to run in target mode" - `twith` (dir, dist, stgtMode)) skip - return $ accessibleDir cops lvl (bpos b) dir - -runDir :: MonadClient m => ActorId -> (Vector, Int) -> m (Vector, Int) -runDir leader (dir, dist) = do - canR <- canRun leader (dir, dist) - let -- Do not count distance if we just open a door. - distNew = if canR then dist + 1 else dist - return (dir, distNew) - --- | Human running mode, determined from the nearby cave layout. -data RunMode = - RunOpen -- ^ open space, in particular the T crossing - | RunHub -- ^ a hub of separate corridors - | RunCorridor !(Vector, Bool) -- ^ a single corridor, turning here or not - | RunDeadEnd -- ^ dead end - --- | Determine the running mode. For corridors, pick the running direction --- trying to explore all corners, by prefering cardinal to diagonal moves. -runMode :: Point -> Vector -> (Point -> Vector -> Bool) -> X -> RunMode -runMode pos dir dirEnterable lxsize = - let dirNearby dir1 dir2 = euclidDistSq lxsize dir1 dir2 == 1 - dirBackward d = euclidDistSq lxsize (neg dir) d <= 1 - dirAhead d = euclidDistSq lxsize dir d <= 2 - findOpen = - let f dirC open = open ++ - case L.filter (dirNearby dirC) dirsEnterable of - l | dirBackward dirC -> dirC : l -- points backwards - [] -> [] -- a narrow corridor, just one tile wide - [_] -> [] -- a turning corridor, two tiles wide - l -> dirC : l -- too wide - in L.foldr f [] - dirsEnterable = L.filter (dirEnterable pos) (moves lxsize) - in case dirsEnterable of - [] -> assert `failure` "actor is stuck" `twith` (pos, dir) -- TODO - [negdir] -> assert (negdir == neg dir) RunDeadEnd - _ -> - let dirsOpen = findOpen dirsEnterable - dirsCorridor = dirsEnterable L.\\ dirsOpen - in case dirsCorridor of - [] -> RunOpen -- no corridors - _ | L.any dirAhead dirsOpen -> RunOpen -- open space ahead - [d] -> RunCorridor (d, False) -- corridor with no turn - [d1, d2] | dirNearby d1 d2 -> -- corridor with a turn - -- Prefer cardinal to diagonal dirs, for hero safety, - -- even if that means changing direction. - RunCorridor (if diagonal lxsize d1 then d2 else d1, True) - _ -> RunHub -- a hub of many separate corridors +-- | Continue running in the given direction. +continueRun :: MonadClient m + => RunParams -> m (Either Msg (RunParams, CmdTakeTimeSer)) +continueRun paramOld = + case paramOld of + RunParams{ runMembers = [] + , runStopMsg = Just stopMsg } -> return $ Left stopMsg + RunParams{ runLeader + , runMembers = r : rs + , runDist = 0 + , runStopMsg + , runInitDir = Just dir } -> + if r == runLeader then do + -- Start a many-actor run with distance 1, to prevent changing + -- direction on first turn, if the original direction is blocked. + -- We want our runners to keep formation. + let runDistNew = if null rs then 0 else 1 + continueRun paramOld{runDist = runDistNew, runInitDir = Nothing} + else do + runOutcome <- continueRunDir r 0 (Just dir) + case runOutcome of + Left "" -> do -- hack; means that zeroth step OK + runStopOrCmd <- moveRunAid r dir + let runMembersNew = if isJust runStopMsg then rs else rs ++ [r] + paramNew = paramOld {runMembers = runMembersNew} + return $! case runStopOrCmd of + Left stopMsg -> assert `failure` (paramOld, stopMsg) + Right runCmd -> Right (paramNew, runCmd) + Left runStopMsgCurrent -> do + let runStopMsgNew = fromMaybe runStopMsgCurrent runStopMsg + paramNew = paramOld { runMembers = rs + , runStopMsg = Just runStopMsgNew } + continueRun paramNew + _ -> assert `failure` (paramOld, runOutcome) + RunParams{ runLeader + , runMembers = r : rs + , runDist + , runStopMsg + , runInitDir = Nothing } -> do + let runDistNew = if r == runLeader then runDist + 1 else runDist + mdirOrRunStopMsgCurrent <- continueRunDir r runDistNew Nothing + let runStopMsgCurrent = + either Just (const Nothing) mdirOrRunStopMsgCurrent + runStopMsgNew = runStopMsg `mplus` runStopMsgCurrent + -- We check @runStopMsgNew@, because even if the current actor + -- runs OK, we want to stop soon if some others had to stop. + runMembersNew = if isJust runStopMsgNew then rs else rs ++ [r] + paramNew = paramOld { runMembers = runMembersNew + , runDist = runDistNew + , runStopMsg = runStopMsgNew } + case mdirOrRunStopMsgCurrent of + Left _ -> continueRun paramNew -- run all undisturbed; only one time + Right dir -> return $ Right (paramNew, MoveSer r dir) + -- The potential invisible actor is hit. War is started without asking. + _ -> assert `failure` paramOld --- TODO: express as MonadActionRO --- | Check for disturbances to running such as newly visible items, monsters. -runDisturbance :: Point -> Int -> Report - -> [Actor] -> [Actor] -> Perception -> Bool -> Point - -> (F.Feature -> Point -> Bool) -> (Point -> Bool) - -> Kind.Ops TileKind -> Level -> X -> Y - -> (Vector, Int) -> Maybe (Vector, Int) -runDisturbance posLast distLast report hs ms per markSuspect posHere - posHasFeature posHasItems - cotile lvl lxsize lysize (dirNew, distNew) = - let boringMsgs = map BS.pack [ "You hear some noises." ] - -- TODO: use a regexp from the UI config instead - msgShown = isJust $ findInReport (`notElem` boringMsgs) report - msposs = ES.delete posHere $ ES.fromList (L.map bpos ms) - enemySeen = - not (ES.null (msposs `ES.intersection` totalVisible per)) - surrLast = posLast : vicinity lxsize lysize posLast - surrHere = posHere : vicinity lxsize lysize posHere - posThere = posHere `shift` dirNew - heroThere = posThere `elem` L.map bpos hs - -- Stop if you touch any individual tile with these propereties - -- first time, unless you enter it next move, in which case stop then. - touchList = [ posHasFeature F.Exit - , posHasItems - ] - -- Here additionally ignore a tile property if you stand on such tile. - standList = [ posHasFeature F.Path - ] - -- Here stop only if you touch any such tile for the first time. - -- TODO: stop when running along a path and it ends (or turns). - -- TODO: perhaps in open areas change direction to follow lit and paths. - firstList = [ posHasFeature F.Lit - , not . posHasFeature F.Lit - , not . posHasFeature F.Path - , \t -> markSuspect && posHasFeature F.Suspect t - -- TODO: refine for suspect floors (e.g., traps) - ] - -- TODO: stop when walls vanish from cardinal directions or when any - -- walls re-appear again. Actually stop one tile before that happens. - -- Then remove some other, subsumed conditions. - -- This will help with corridors starting in dark rooms. - touchNew fun = - let touchLast = L.filter fun surrLast - touchHere = L.filter fun surrHere - in touchHere L.\\ touchLast - touchExplore fun = touchNew fun == [posThere] - touchStop fun = touchNew fun /= [] - standNew fun = L.filter (\pos -> posHasFeature F.Walkable pos || - Tile.openable cotile (lvl `at` pos)) - (touchNew fun) - standExplore fun = not (fun posHere) && standNew fun == [posThere] - standStop fun = not (fun posHere) && standNew fun /= [] - firstNew fun = L.all (not . fun) surrLast && - L.any fun surrHere - firstExplore fun = firstNew fun && fun posThere - firstStop = firstNew - tryRunMaybe - | msgShown || enemySeen - || heroThere || distLast >= 40 = Nothing - | L.any touchExplore touchList = Just (dirNew, 1000) - | L.any standExplore standList = Just (dirNew, 1000) - | L.any firstExplore firstList = Just (dirNew, 1000) - | L.any touchStop touchList = Nothing - | L.any standStop standList = Nothing - | L.any firstStop firstList = Nothing - | otherwise = Just (dirNew, distNew) - in tryRunMaybe +-- | Actor moves or searches or alters. No visible actor at the position. +moveRunAid :: MonadClient m + => ActorId -> Vector -> m (Either Msg CmdTakeTimeSer) +moveRunAid source dir = do + cops@Kind.COps{cotile} <- getsState scops + sb <- getsState $ getActorBody source + let lid = blid sb + lvl <- getLevel lid + let spos = bpos sb -- source position + tpos = spos `shift` dir -- target position + t = lvl `at` tpos + runStopOrCmd = + -- Movement requires full access. + if accessible cops lvl spos tpos then + -- The potential invisible actor is hit. War started without asking. + Right $ MoveSer source dir + -- No access, so search and/or alter the tile. Non-walkability is + -- not implied by the lack of access. + else if not (Tile.isWalkable cotile t) + && (isSecretPos lvl tpos -- possible secrets here + && (Tile.isSuspect cotile t -- not yet searched + || hideTile cotile lvl tpos /= t) -- searching again + || Tile.isOpenable cotile t + || Tile.isClosable cotile t + || Tile.isChangeable cotile t) then + if not $ EM.null $ lvl `atI` tpos then + Left $ showFailureSer AlterBlockItem + else + Right $ AlterSer source tpos Nothing + -- We don't use MoveSer, because we don't hit invisible actors. + -- The potential invisible actor, e.g., in a wall or in + -- an inaccessible doorway, is made known, taking a turn. + -- If server performed an attack for free + -- on the invisible actor anyway, the player (or AI) + -- would be tempted to repeatedly hit random walls + -- in hopes of killing a monster lurking within. + -- If the action had a cost, misclicks would incur the cost, too. + -- Right now the player may repeatedly alter tiles trying to learn + -- about invisible pass-wall actors, but it costs a turn + -- and does not harm the invisible actors, so it's not tempting. + -- Ignore a known boring, not accessible tile. + else Left "never mind" + return $! runStopOrCmd -- | This function implements the actual logic of running. It checks if we -- have to stop running because something interesting cropped up, -- it ajusts the direction given by the vector if we reached -- a corridor's corner (we never change direction except in corridors) -- and it increments the counter of traversed tiles. -continueRunDir :: MonadClientAbort m - => ActorId -> (Vector, Int) - -> m (Vector, Int) -continueRunDir leader (dirLast, distLast) = do +continueRunDir :: MonadClient m + => ActorId -> Int -> Maybe Vector -> m (Either Msg Vector) +continueRunDir aid distLast mdir = do + sreport <- getsClient sreport -- TODO: check the message before it goes into history + let boringMsgs = map BS.pack [ "You hear some noises." + , "reveals that the" ] + boring repLine = any (`BS.isInfixOf` repLine) boringMsgs + -- TODO: use a regexp from the UI config instead + msgShown = isJust $ findInReport (not . boring) sreport + if msgShown then return $ Left "message shown" + else do + let maxDistance = 20 + cops@Kind.COps{cotile} <- getsState scops + body <- getsState $ getActorBody aid + let lid = blid body + lvl <- getLevel lid + let posHere = bpos body + posLast = boldpos body + dirLast = displacement posLast posHere + dir = fromMaybe dirLast mdir + posThere = posHere `shift` dir + actorsThere <- getsState $ posToActors posThere lid + let openableLast = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir)) + check + | not $ null actorsThere = return $ Left "actor in the way" + -- don't displace actors, except with leader in step 1 + | distLast >= maxDistance = + return $ Left $ "reached max run distance" <+> tshow maxDistance + | accessibleDir cops lvl posHere dir = + if distLast == 0 + then return $ Left "" -- hack; means that zeroth step OK + else checkAndRun aid dir + | distLast /= 1 = return $ Left "blocked" + -- don't change direction, except in step 1 + | openableLast = return $ Left "blocked by a closed door" + -- the player may prefer to open the door + | otherwise = + -- Assume turning is permitted, because this is the start + -- of the run, so the situation is mostly known to the player + tryTurning aid + check + +tryTurning :: MonadClient m + => ActorId -> m (Either Msg Vector) +tryTurning aid = do cops@Kind.COps{cotile} <- getsState scops - body <- getsState $ getActorBody leader + body <- getsState $ getActorBody aid let lid = blid body - per <- getPerFid lid - sreport <- getsClient sreport -- TODO: check the message before it goes into history + lvl <- getLevel lid + let posHere = bpos body + posLast = boldpos body + dirLast = displacement posLast posHere + let openableDir dir = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir)) + dirEnterable dir = accessibleDir cops lvl posHere dir || openableDir dir + dirNearby dir1 dir2 = euclidDistSqVector dir1 dir2 `elem` [1, 2] + dirSimilar dir = dirNearby dirLast dir && dirEnterable dir + dirsSimilar = filter dirSimilar moves + case dirsSimilar of + [] -> return $ Left "dead end" + d1 : ds | all (dirNearby d1) ds -> -- only one or two directions possible + case sortBy (compare `on` euclidDistSqVector dirLast) + $ filter (accessibleDir cops lvl posHere) $ d1 : ds of + [] -> + return $ Left "blocked and all similar directions are closed doors" + d : _ -> checkAndRun aid d + _ -> return $ Left "blocked and many distant similar directions found" + +-- The direction is different than the original, if called from @tryTurning@ +-- and the same if from @continueRunDir@. +checkAndRun :: MonadClient m + => ActorId -> Vector -> m (Either Msg Vector) +checkAndRun aid dir = do + Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops + body <- getsState $ getActorBody aid smarkSuspect <- getsClient smarkSuspect - fact <- getsState $ (EM.! bfid body) . sfactionD - ms <- getsState $ actorList (isAtWar fact) lid - hs <- getsState $ actorList (not . isAtWar fact) lid - lvl@Level{lxsize, lysize} <- getLevel $ blid body + let lid = blid body + lvl <- getLevel lid let posHere = bpos body - posHasFeature f pos = Tile.hasFeature cotile f (lvl `at` pos) posHasItems pos = not $ EM.null $ lvl `atI` pos - posLast = if distLast == 0 then posHere else posHere `shift` neg dirLast - tryRunDist (dir, distNew) - | accessibleDir cops lvl posHere dir = - -- TODO: perhaps @abortWith report2? - maybe abort (runDir leader) $ - runDisturbance - posLast distLast sreport hs ms per smarkSuspect posHere - posHasFeature posHasItems cotile lvl lxsize lysize (dir, distNew) - | otherwise = abort -- do not open doors in the middle of a run - tryRun dir = tryRunDist (dir, distLast) - _tryRunAndStop dir = tryRunDist (dir, 1000) - openableDir pos dir = Tile.openable cotile (lvl `at` (pos `shift` dir)) - dirEnterable pos d = accessibleDir cops lvl pos d || openableDir pos d - case runMode posHere dirLast dirEnterable lxsize of - RunDeadEnd -> abort -- we don't run backwards - RunOpen -> tryRun dirLast -- run forward into the open space - RunHub -> abort -- stop and decide where to go - RunCorridor (dirNext, _turn) -> -- look ahead - tryRun dirNext - -- TODO: instead of a lookahead (does not work, since clients have - -- limited knowledge), pass _turn similarly as in (dir, 1000) - -- and decide next turn. - -- TODO: perhaps boldpos can be handy here - -- case runMode (posHere `shift` dirNext) dirNext dirEnterable lxsize of - -- RunDeadEnd -> tryRun dirNext -- explore the dead end - -- RunCorridor _ -> tryRun dirNext -- follow the corridor - -- RunOpen | turn -> abort -- stop and decide when to turn - -- RunHub | turn -> abort -- stop and decide when to turn - -- RunOpen -> tryRunAndStop dirNext -- no turn, get closer and stop - -- RunHub -> tryRunAndStop dirNext -- no turn, get closer and stop + posThere = posHere `shift` dir + actorsThere <- getsState $ posToActors posThere lid + let posLast = boldpos body + dirLast = displacement posLast posHere + -- This is supposed to work on unit vectors --- diagonal, as well as, + -- vertical and horizontal. + anglePos :: Point -> Vector -> RadianAngle -> Point + anglePos pos d angle = shift pos (rotate angle d) + -- We assume the tiles have not changes since last running step. + -- If they did, we don't care --- running should be stopped + -- because of the change of nearby tiles then (TODO). + -- We don't take into account the two tiles at the rear of last + -- surroundings, because the actor may have come from there + -- (via a diagonal move) and if so, he may be interested in such tiles. + -- If he arrived directly from the right or left, he is responsible + -- for starting the run further away, if he does not want to ignore + -- such tiles as the ones he came from. + tileLast = lvl `at` posLast + tileHere = lvl `at` posHere + tileThere = lvl `at` posThere + leftPsLast = map (anglePos posHere dirLast) [pi/2, 3*pi/4] + ++ map (anglePos posHere dir) [pi/2, 3*pi/4] + rightPsLast = map (anglePos posHere dirLast) [-pi/2, -3*pi/4] + ++ map (anglePos posHere dir) [-pi/2, -3*pi/4] + leftForwardPosHere = anglePos posHere dir (pi/4) + rightForwardPosHere = anglePos posHere dir (-pi/4) + leftTilesLast = map (lvl `at`) leftPsLast + rightTilesLast = map (lvl `at`) rightPsLast + leftForwardTileHere = lvl `at` leftForwardPosHere + rightForwardTileHere = lvl `at` rightForwardPosHere + featAt = actionFeatures smarkSuspect . okind + terrainChangeMiddle = null (Tile.causeEffects cotile tileThere) + -- step into; will stop next turn due to message + && featAt tileThere + `notElem` map featAt [tileLast, tileHere] + terrainChangeLeft = featAt leftForwardTileHere + `notElem` map featAt leftTilesLast + terrainChangeRight = featAt rightForwardTileHere + `notElem` map featAt rightTilesLast + itemChangeLeft = posHasItems leftForwardPosHere + `notElem` map posHasItems leftPsLast + itemChangeRight = posHasItems rightForwardPosHere + `notElem` map posHasItems rightPsLast + check + | not $ null actorsThere = return $ Left "actor in the way" + -- Actor in possibly another direction tnat original. + | terrainChangeLeft = return $ Left "terrain change on the left" + | terrainChangeRight = return $ Left "terrain change on the right" + | itemChangeLeft = return $ Left "item change on the left" + | itemChangeRight = return $ Left "item change on the right" + | terrainChangeMiddle = return $ Left "terrain change in the middle" + | otherwise = return $ Right dir + check diff --git a/Game/LambdaHack/Client/State.hs b/Game/LambdaHack/Client/State.hs --- a/Game/LambdaHack/Client/State.hs +++ b/Game/LambdaHack/Client/State.hs @@ -1,16 +1,19 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Server and client game state types and operations. module Game.LambdaHack.Client.State ( StateClient(..), defStateClient, defHistory , updateTarget, getTarget, updateLeader, sside - , TgtMode(..), Target(..) + , PathEtc, TgtMode(..), Target(..), RunParams(..), LastRecord , toggleMarkVision, toggleMarkSmell, toggleMarkSuspect ) where +import Control.Exception.Assert.Sugar import Control.Monad import Data.Binary import qualified Data.EnumMap.Strict as EM +import qualified Data.EnumSet as ES +import Data.Text (Text) import qualified Data.Text as T -import Game.LambdaHack.Common.Vector import qualified NLP.Miniutter.English as MU import qualified System.Random as R import System.Time @@ -27,8 +30,10 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point +import qualified Game.LambdaHack.Common.PointArray as PointArray +import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State -import Control.Exception.Assert.Sugar +import Game.LambdaHack.Common.Vector -- | Client state, belonging to a single faction. -- Some of the data, e.g, the history, carries over @@ -36,54 +41,93 @@ -- Data invariant: if @_sleader@ is @Nothing@ then so is @srunning@. data StateClient = StateClient { stgtMode :: !(Maybe TgtMode) -- ^ targeting mode - , scursor :: !(Maybe Point) -- ^ cursor coordinates + , scursor :: !Target -- ^ the common, cursor target , seps :: !Int -- ^ a parameter of the tgt digital line - , stargetD :: !(EM.EnumMap ActorId Target) + , stargetD :: !(EM.EnumMap ActorId (Target, Maybe PathEtc)) -- ^ targets of our actors in the dungeon - , srunning :: !(Maybe (Vector, Int)) - -- ^ direction and distance of running + , sexplored :: !(ES.EnumSet LevelId) + -- ^ the set of fully explored levels + , sbfsD :: !(EM.EnumMap ActorId + ( PointArray.Array BfsDistance + , Point, Int, Maybe [Point]) ) + -- ^ pathfinding distances for our actors + -- and paths to their targets, if any + , sselected :: !(ES.EnumSet ActorId) + -- ^ the set of currently selected actors + , srunning :: !(Maybe RunParams) + -- ^ parameters of the current run, if any , sreport :: !Report -- ^ current messages , shistory :: !History -- ^ history of messages , sundo :: ![Atomic] -- ^ atomic commands performed to date , sdisco :: !Discovery -- ^ remembered item discoveries , sfper :: !FactionPers -- ^ faction perception indexed by levels , srandom :: !R.StdGen -- ^ current random generator - , sconfigUI :: !ConfigUI -- ^ client config (including initial RNG) + , sconfigUI :: ConfigUI -- ^ client config (including initial RNG) , slastKey :: !(Maybe K.KM) -- ^ last command key pressed - , _sleader :: !(Maybe ActorId) -- ^ selected actor + , slastRecord :: !LastRecord -- ^ state of key sequence recording + , slastPlay :: ![K.KM] -- ^ state of key sequence playback + , slastCmd :: !(Maybe CmdTakeTimeSer) + -- ^ last command sent to the server + , swaitTimes :: !Int -- ^ player just waited this many times + , _sleader :: !(Maybe ActorId) + -- ^ current picked party leader , _sside :: !FactionId -- ^ faction controlled by the client , squit :: !Bool -- ^ exit the game loop , sisAI :: !Bool -- ^ whether it's an AI client , smarkVision :: !Bool -- ^ mark leader and party FOV , smarkSmell :: !Bool -- ^ mark smell, if the leader can smell , smarkSuspect :: !Bool -- ^ mark suspect features + , scurDifficulty :: !Int -- ^ current game difficulty level , sdebugCli :: !DebugModeCli -- ^ client debugging mode } - deriving (Show) + deriving Show +type PathEtc = ([Point], (Point, Int)) + -- | Current targeting mode of a client. -data TgtMode = - TgtExplicit { tgtLevelId :: !LevelId } - -- ^ the player requested targeting mode explicitly - | TgtAuto { tgtLevelId :: !LevelId } - -- ^ the mode was entered (and will be exited) automatically - deriving (Show, Eq) +newtype TgtMode = TgtMode { tgtLevelId :: LevelId } + deriving (Show, Eq, Binary) -- | The type of na actor target. data Target = - TEnemy !ActorId !Point -- ^ target an actor with its last seen position - | TPos !Point -- ^ target a given position + TEnemy !ActorId !Bool + -- ^ target an actor; cycle only trough seen foes, unless the flag is set + | TEnemyPos !ActorId !LevelId !Point !Bool + -- ^ last seen position of the targeted actor + | TPoint !LevelId !Point -- ^ target a concrete spot + | TVector !Vector -- ^ target position relative to actor deriving (Show, Eq) +-- | Parameters of the current run. +data RunParams = RunParams + { runLeader :: !ActorId -- ^ the original leader from run start + , runMembers :: ![ActorId] -- ^ the list of actors that take part + , runDist :: !Int -- ^ distance of the run so far + -- (plus one, if multiple runners) + , runStopMsg :: !(Maybe Text) -- ^ message with the next stop reason + , runInitDir :: !(Maybe Vector) -- ^ the direction of the initial step + } + deriving (Show) + +type LastRecord = ( [K.KM] -- accumulated keys of the current command + , [K.KM] -- keys of the rest of the recorded command batch + , Int -- commands left to record for this batch + ) + -- | Initial game client state. defStateClient :: History -> ConfigUI -> FactionId -> Bool -> StateClient defStateClient shistory sconfigUI _sside sisAI = StateClient { stgtMode = Nothing - , scursor = Nothing + , scursor = if sisAI + then TVector $ Vector 30000 30000 -- invalid + else TVector $ Vector 1 1 -- a step south-east , seps = 0 , stargetD = EM.empty + , sexplored = ES.empty + , sbfsD = EM.empty + , sselected = ES.empty , srunning = Nothing , sreport = emptyReport , shistory @@ -93,6 +137,10 @@ , sconfigUI , srandom = R.mkStdGen 42 -- will be set later , slastKey = Nothing + , slastRecord = ([], [], 0) + , slastPlay = [] + , slastCmd = Nothing + , swaitTimes = 0 , _sleader = Nothing -- no heroes yet alive , _sside , squit = False @@ -100,6 +148,7 @@ , smarkVision = False , smarkSmell = False , smarkSuspect = False + , scurDifficulty = 0 , sdebugCli = defDebugModeCli } @@ -107,19 +156,23 @@ defHistory = do dateTime <- getClockTime let curDate = MU.Text $ T.pack $ calendarTimeToString $ toUTCTime dateTime - return $ singletonHistory $ singletonReport - $ makeSentence ["Human history log started on", curDate] + return $! singletonHistory $ singletonReport + $! makeSentence ["Human history log started on", curDate] -- | Update target parameters within client state. updateTarget :: ActorId -> (Maybe Target -> Maybe Target) -> StateClient -> StateClient -updateTarget aid f cli = cli { stargetD = EM.alter f aid (stargetD cli) } +updateTarget aid f cli = + let f2 tp = case f $ fmap fst tp of + Nothing -> Nothing + Just tgt -> Just (tgt, Nothing) -- reset path + in cli {stargetD = EM.alter f2 aid (stargetD cli)} -- | Get target parameters from client state. getTarget :: ActorId -> StateClient -> Maybe Target -getTarget aid cli = EM.lookup aid (stargetD cli) +getTarget aid cli = fmap fst $ EM.lookup aid $ stargetD cli --- | Update selected actor within state. Verify actor's faction. +-- | Update picked leader within state. Verify actor's faction. updateLeader :: ActorId -> State -> StateClient -> StateClient updateLeader leader s cli = let side1 = bfid $ getActorBody leader s @@ -147,61 +200,81 @@ put scursor put seps put stargetD + put sexplored + put sselected put srunning put sreport put shistory put sundo put sdisco put (show srandom) - put sconfigUI put _sleader put _sside put sisAI put smarkVision put smarkSmell put smarkSuspect - put sdebugCli + put scurDifficulty + put sdebugCli -- TODO: this is overwritten at once get = do stgtMode <- get scursor <- get seps <- get stargetD <- get + sexplored <- get + sselected <- get srunning <- get sreport <- get shistory <- get sundo <- get sdisco <- get g <- get - sconfigUI <- get _sleader <- get _sside <- get sisAI <- get smarkVision <- get smarkSmell <- get smarkSuspect <- get + scurDifficulty <- get sdebugCli <- get - let sfper = EM.empty + let sbfsD = EM.empty + sfper = EM.empty srandom = read g slastKey = Nothing + slastRecord = ([], [], 0) + slastPlay = [] + slastCmd = Nothing + swaitTimes = 0 squit = False - return StateClient{..} + sconfigUI = undefined + return $! StateClient{..} -instance Binary TgtMode where - put (TgtExplicit l) = putWord8 0 >> put l - put (TgtAuto l) = putWord8 1 >> put l +instance Binary RunParams where + put RunParams{..} = do + put runLeader + put runMembers + put runDist + put runStopMsg + put runInitDir get = do - tag <- getWord8 - case tag of - 0 -> liftM TgtExplicit get - 1 -> liftM TgtAuto get - _ -> fail "no parse (TgtMode)" + runLeader <- get + runMembers <- get + runDist<- get + runStopMsg <- get + runInitDir <- get + return $! RunParams{..} instance Binary Target where - put (TEnemy a ll) = putWord8 0 >> put a >> put ll - put (TPos pos) = putWord8 1 >> put pos + put (TEnemy a permit) = putWord8 0 >> put a >> put permit + put (TEnemyPos a lid p permit) = + putWord8 1 >> put a >> put lid >> put p >> put permit + put (TPoint lid p) = putWord8 2 >> put lid >> put p + put (TVector v) = putWord8 3 >> put v get = do tag <- getWord8 case tag of 0 -> liftM2 TEnemy get get - 1 -> liftM TPos get + 1 -> liftM4 TEnemyPos get get get get + 2 -> liftM2 TPoint get get + 3 -> liftM TVector get _ -> fail "no parse (Target)" diff --git a/Game/LambdaHack/Client/Strategy.hs b/Game/LambdaHack/Client/Strategy.hs --- a/Game/LambdaHack/Client/Strategy.hs +++ b/Game/LambdaHack/Client/Strategy.hs @@ -22,7 +22,8 @@ -- | Strategy is a monad. TODO: Can we write this as a monad transformer? instance Monad Strategy where - return x = Strategy $ return $ uniformFreq "Strategy_return" [x] + {-# INLINE return #-} + return x = Strategy $ return $! uniformFreq "Strategy_return" [x] m >>= f = normalizeStrategy $ Strategy [ toFreq name [ (p * q, b) | (p, a) <- runFrequency x @@ -36,16 +37,17 @@ fmap f (Strategy fs) = Strategy (map (fmap f) fs) instance Applicative Strategy where - pure = return - (<*>) = ap + pure = return + (<*>) = ap instance MonadPlus Strategy where mzero = Strategy [] + {-# INLINE mplus #-} mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys) instance Alternative Strategy where - (<|>) = mplus - empty = mzero + (<|>) = mplus + empty = mzero normalizeStrategy :: Strategy a -> Strategy a normalizeStrategy (Strategy fs) = Strategy $ filter (not . nullFreq) fs @@ -95,4 +97,4 @@ -- | Like 'return', but pick a name of the single frequency. returN :: Text -> a -> Strategy a -returN name x = Strategy $ return $ uniformFreq name [x] +returN name x = Strategy $ return $! uniformFreq name [x] diff --git a/Game/LambdaHack/Client/StrategyAction.hs b/Game/LambdaHack/Client/StrategyAction.hs --- a/Game/LambdaHack/Client/StrategyAction.hs +++ b/Game/LambdaHack/Client/StrategyAction.hs @@ -1,13 +1,16 @@ -- | AI strategy operations implemented with the 'Action' monad. module Game.LambdaHack.Client.StrategyAction - ( targetStrategy, actionStrategy, visibleFoes + ( targetStrategy, actionStrategy ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM +import qualified Data.EnumSet as ES import Data.Function import Data.List import Data.Maybe +import Data.Ord import qualified Data.Traversable as Traversable import Game.LambdaHack.Client.Action @@ -24,8 +27,8 @@ import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Random as Random import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State @@ -33,184 +36,294 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ActorKind +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind as TileKind -import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency -- | AI proposes possible targets for the actor. Never empty. -targetStrategy :: MonadClient m - => ActorId -> [Ability] -> m (Strategy (Maybe Target)) -targetStrategy aid factionAbilities = do - btarget <- getsClient $ getTarget aid - fper <- getsClient sfper - reacquireTgt aid factionAbilities btarget fper - -visibleFoes :: MonadActionRO m - => ActorId -> FactionPers -> m [(ActorId, Actor)] -visibleFoes aid fper = do +targetStrategy :: forall m. MonadClient m + => ActorId -> ActorId -> m (Strategy (Target, PathEtc)) +targetStrategy oldLeader aid = do + Kind.COps{ cotile=cotile@Kind.Ops{ouniqGroup} + , coactor=Kind.Ops{okind} + , cofaction=Kind.Ops{okind=fokind} } <- getsState scops + modifyClient $ \cli -> cli {sbfsD = EM.delete aid (sbfsD cli)} b <- getsState $ getActorBody aid + mtgtMPath <- getsClient $ EM.lookup aid . stargetD + oldTgtUpdatedPath <- case mtgtMPath of + Just (tgt, Just path) -> do + mvalidPos <- aidTgtToPos aid (blid b) (Just tgt) + if isNothing mvalidPos then return Nothing -- wrong level + else return $! case path of + (p : q : rest, (goal, len)) -> + if bpos b == p + then Just (tgt, path) -- no move last turn + else if bpos b == q + then Just (tgt, (q : rest, (goal, len - 1))) -- step along path + else Nothing -- veered off the path + ([p], (goal, _)) -> do + assert (p == goal `blame` (aid, b, mtgtMPath)) skip + if bpos b == p then + Just (tgt, path) -- goal reached; stay there picking up items + else + Nothing -- somebody pushed us off the goal; let's target again + ([], _) -> assert `failure` (aid, b, mtgtMPath) + Just (_, Nothing) -> return Nothing -- path invalidated, e.g. SpotActorA + Nothing -> return Nothing -- no target assigned yet + lvl <- getLevel $ blid b assert (not $ bproj b) skip -- would work, but is probably a bug - let per = fper EM.! blid b fact <- getsState $ \s -> sfactionD s EM.! bfid b - foes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid b) - return $! filter (actorSeesPos per aid . bpos . snd) foes - -reacquireTgt :: MonadActionRO m - => ActorId -> [Ability] -> Maybe Target -> FactionPers - -> m (Strategy (Maybe Target)) -reacquireTgt aid factionAbilities btarget fper = do - cops@Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops - b <- getsState $ getActorBody aid - assert (not $ bproj b) skip -- would work, but is probably a bug - lvl@Level{lxsize} <- getsState $ \s -> sdungeon s EM.! blid b - visFoes <- visibleFoes aid fper - actorD <- getsState sactorD - -- TODO: set distant targets so that monsters behave as if they have - -- a plan. We need pathfinding for that. - noFoes :: Strategy (Maybe Target) <- do - s <- getState - str <- moveStrategy cops aid s Nothing - return $ (Just . TPos . (bpos b `shift`)) `liftM` str - let per = fper EM.! blid b - mk = okind $ bkind b - actorAbilities = acanDo mk `intersect` factionAbilities - focused = bspeed b <= speedNormal - -- Don't focus on a distant enemy, when you can't chase him. - -- TODO: or only if another enemy adjacent? consider Flee? - && Ability.Chase `elem` actorAbilities - closest :: Strategy (Maybe Target) - closest = - let distB = chessDist lxsize (bpos b) - foeDist = map (\(_, body) -> distB (bpos body)) visFoes - minDist | null foeDist = maxBound - | otherwise = minimum foeDist - minFoes = - filter (\(_, body) -> distB (bpos body) == minDist) visFoes - minTargets = map (\(a, body) -> - Just $ TEnemy a $ bpos body) minFoes - minTgtS = liftFrequency $ uniformFreq "closest" minTargets - in minTgtS .| noFoes .| returN "TCursor" Nothing -- never empty - reacquire :: Maybe Target -> Strategy (Maybe Target) - reacquire tgt = - case tgt of - Just (TEnemy a ll) | focused -> -- chase even if enemy dead, to loot - case fmap bpos $ EM.lookup a actorD of - Just l | actorSeesPos per aid l -> - -- prefer visible (and alive) foes - returN "TEnemy" $ Just $ TEnemy a l - _ -> if null visFoes -- prefer visible foes to positions - && bpos b /= ll -- not yet reached the last pos - then returN "last known" $ Just $ TPos ll - -- chase the last known pos - else closest - Just TEnemy{} -> closest -- just pick the closest foe - Just (TPos pos) | bpos b == pos -> closest -- already reached pos - Just (TPos pos) - | not $ bumpableHere cops lvl False (asight mk) pos -> - closest -- no longer bumpable, even assuming no foes - Just TPos{} | null visFoes -> returN "TPos" tgt - -- nothing visible, go to pos - Just TPos{} -> closest -- prefer visible foes - Nothing -> closest - return $! reacquire btarget + allFoes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid b) + dungeon <- getsState sdungeon + -- TODO: we assume the actor eventually becomes a leader (or has the same + -- set of abilities as the leader, anyway) and set his target accordingly. + actorAbs <- actorAbilities aid (Just aid) + let nearby = 10 + nearbyFoes = filter (\(_, body) -> + chessDist (bpos body) (bpos b) < nearby) allFoes + unknownId = ouniqGroup "unknown space" + -- TODO: make more common when weak ranged foes preferred, etc. + focused = bspeed b < speedNormal + canSmell = asmell $ okind $ bkind b + setPath :: Target -> m (Strategy (Target, PathEtc)) + setPath tgt = do + mpos <- aidTgtToPos aid (blid b) (Just tgt) + let p = fromMaybe (assert `failure` (b, tgt)) mpos + (bfs, mpath) <- getCacheBfsAndPath aid p + case mpath of + Nothing -> assert `failure` "new target unreachable" `twith` (b, tgt) + Just path -> + return $! returN "pickNewTarget" + (tgt, ( bpos b : path + , (p, fromMaybe (assert `failure` mpath) + $ accessBfs bfs p) )) + pickNewTarget :: m (Strategy (Target, PathEtc)) + pickNewTarget = do + -- TODO: for foes, items, etc. consider a few nearby, not just one + cfoes <- closestFoes aid + case cfoes of + (_, (a, _)) : _ -> setPath $ TEnemy a False + [] -> do + -- Tracking enemies is more important than exploring, + -- and smelling actors are usually blind, so bad at exploring. + -- TODO: prefer closer items to older smells + smpos <- if canSmell + then closestSmell aid + else return [] + case smpos of + [] -> do + citems <- if Ability.Pickup `elem` actorAbs + then closestItems aid + else return [] + case citems of + [] -> do + upos <- closestUnknown aid + case upos of + Nothing -> do + ctriggers <- if Ability.Trigger `elem` actorAbs + then closestTriggers Nothing False aid + else return [] + case ctriggers of + [] -> do + getDistant <- + rndToAction $ oneOf + $ [fmap maybeToList . furthestKnown] + ++ [ closestTriggers Nothing True + | EM.size dungeon > 1 ] + kpos <- getDistant aid + case kpos of + [] -> return reject + p : _ -> setPath $ TPoint (blid b) p + p : _ -> setPath $ TPoint (blid b) p + Just p -> setPath $ TPoint (blid b) p + (_, (p, _)) : _ -> setPath $ TPoint (blid b) p + (_, (p, _)) : _ -> setPath $ TPoint (blid b) p + tellOthersNothingHere pos = do + let f (tgt, _) = case tgt of + TEnemyPos _ lid p _ -> p /= pos || lid /= blid b + _ -> True + modifyClient $ \cli -> cli {stargetD = EM.filter f (stargetD cli)} + pickNewTarget + updateTgt :: Target -> PathEtc + -> m (Strategy (Target, PathEtc)) + updateTgt oldTgt updatedPath = case oldTgt of + TEnemy a _ -> do + body <- getsState $ getActorBody a + if not focused -- prefers closer foes + && not (null nearbyFoes) -- foes nearby + && a `notElem` map fst nearbyFoes -- old one not close enough + || blid body /= blid b -- wrong level + then pickNewTarget + else if bpos body == fst (snd updatedPath) + then return $! returN "TEnemy" (oldTgt, updatedPath) + -- The enemy didn't move since the target acquired. + -- If any walls were added that make the enemy + -- unreachable, AI learns that the hard way, + -- as soon as it bumps into them. + else do + let p = bpos body + (bfs, mpath) <- getCacheBfsAndPath aid p + case mpath of + Nothing -> pickNewTarget -- enemy became unreachable + Just path -> + return $! returN "TEnemy" + (oldTgt, ( bpos b : path + , (p, fromMaybe (assert `failure` mpath) + $ accessBfs bfs p) )) + _ | not $ null nearbyFoes -> + pickNewTarget -- prefer close foes to anything + TPoint lid pos -> do + explored <- getsClient sexplored + let allExplored = ES.size explored == EM.size dungeon + abilityLeader = fAbilityLeader $ fokind $ gkind fact + abilityOther = fAbilityOther $ fokind $ gkind fact + if lid /= blid b -- wrong level + -- Below we check the target could not be picked again in + -- pickNewTarget, and only in this case it is invalidated. + -- This ensures targets are eventually reached (unless a foe + -- shows up) and not changed all the time mid-route + -- to equally interesting, but perhaps a bit closer targets, + -- most probably already targeted by other actors. + || (Ability.Pickup `notElem` actorAbs -- closestItems + || EM.null (lvl `atI` pos)) + && (not canSmell -- closestSmell + || pos == bpos b -- in case server resends deleted smell + || let sml = + EM.findWithDefault timeZero pos (lsmell lvl) + in sml `timeAdd` timeNegate (ltime lvl) <= timeZero) + && let t = lvl `at` pos + in if ES.notMember lid explored + then -- closestUnknown + t /= unknownId + && not (Tile.isSuspect cotile t) + else -- closestTriggers + -- Try to kill that very last enemy for his loot before + -- leaving the level or dungeon. + not (null allFoes) + || -- If all explored, escape/block escapes. + (Ability.Trigger `notElem` actorAbs + || not (Tile.isEscape cotile t && allExplored)) + -- The next case is stairs in closestTriggers. + -- We don't determine if the stairs are interesting + -- (this changes with time), but allow the actor + -- to reach them and then retarget. + && not (pos /= bpos b && Tile.isStair cotile t) + -- The remaining case is furthestKnown. This is + -- always an unimportant target, so we forget it + -- if the actor is stuck (could move, but waits). + && let isStuck = + waitedLastTurn b + && (oldLeader == aid + || abilityLeader == abilityOther) + in not (pos /= bpos b + && not isStuck + && allExplored) + then pickNewTarget + else return $! returN "TPoint" (oldTgt, updatedPath) + _ | not $ null allFoes -> + pickNewTarget -- new likely foes location spotted, forget the old + TEnemyPos _ lid p _ -> + -- Chase last position even if foe hides or dies, + -- to find his companions, loot, etc. + if lid /= blid b -- wrong level + then pickNewTarget + else if p == bpos b + then tellOthersNothingHere p + else return $! returN "TEnemyPos" (oldTgt, updatedPath) + TVector{} -> pickNewTarget + case oldTgtUpdatedPath of + Just (oldTgt, updatedPath) -> updateTgt oldTgt updatedPath + Nothing -> pickNewTarget --- | AI strategy based on actor's sight, smell, intelligence, etc. Never empty. -actionStrategy :: MonadClient m - => ActorId -> [Ability] -> m (Strategy CmdSerTakeTime) -actionStrategy aid factionAbilities = do +-- | AI strategy based on actor's sight, smell, intelligence, etc. +-- Never empty. +actionStrategy :: forall m. MonadClient m + => ActorId -> m (Strategy CmdTakeTimeSer) +actionStrategy aid = do + cops <- getsState scops disco <- getsClient sdisco btarget <- getsClient $ getTarget aid - proposeAction disco aid factionAbilities btarget - -proposeAction :: MonadActionRO m - => Discovery -> ActorId -> [Ability] -> Maybe Target - -> m (Strategy CmdSerTakeTime) -proposeAction disco aid factionAbilities btarget = do - Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops - Actor{bkind, bpos, blid} <- getsState $ getActorBody aid + Actor{bpos, blid} <- getsState $ getActorBody aid + bitems <- getsState $ getActorItem aid + lootItems <- getsState $ getFloorItem blid bpos lvl <- getLevel blid - let mk = okind bkind - (fpos, mfAid) = + mleader <- getsClient _sleader + actorAbs <- actorAbilities aid mleader + let mfAid = case btarget of - Just (TEnemy foeAid l) -> (l, Just foeAid) - Just (TPos l) -> (l, Nothing) - Nothing -> (bpos, Nothing) -- an actor blocked by friends or a missile + Just (TEnemy foeAid _) -> Just foeAid + _ -> Nothing foeVisible = isJust mfAid lootHere x = not $ EM.null $ lvl `atI` x - actorAbilities = acanDo mk `intersect` factionAbilities + lootIsWeapon = isJust $ strongestSword cops lootItems + hasNoWeapon = isNothing $ strongestSword cops bitems isDistant = (`elem` [ Ability.Trigger , Ability.Ranged , Ability.Tools , Ability.Chase ]) -- TODO: this is too fragile --- depends on order of abilities - (prefix, rest) = break isDistant actorAbilities + (prefix, rest) = break isDistant actorAbs (distant, suffix) = partition isDistant rest - -- TODO: Ranged and Tools should only be triggered in some situations. - aFrequency :: MonadActionRO m => Ability -> m (Frequency CmdSerTakeTime) + aFrequency :: Ability -> m (Frequency CmdTakeTimeSer) aFrequency Ability.Trigger = if foeVisible then return mzero else triggerFreq aid - aFrequency Ability.Ranged = if not foeVisible then return mzero - else rangedFreq disco aid fpos - aFrequency Ability.Tools = if not foeVisible then return mzero - else toolsFreq disco aid - aFrequency Ability.Chase = if fpos == bpos then return mzero - else chaseFreq - aFrequency ab = assert `failure` "unexpected ability" - `twith` (ab, distant, actorAbilities) - chaseFreq :: MonadActionRO m => m (Frequency CmdSerTakeTime) + aFrequency Ability.Ranged = rangedFreq aid + aFrequency Ability.Tools = if not foeVisible then return mzero + else toolsFreq disco aid + aFrequency Ability.Chase = if not foeVisible then return mzero + else chaseFreq + aFrequency ab = assert `failure` "unexpected ability" + `twith` (ab, distant, actorAbs) + chaseFreq :: MonadActionRO m => m (Frequency CmdTakeTimeSer) chaseFreq = do - st <- chase aid (fpos, foeVisible) - return $ scaleFreq 30 $ bestVariant st - aStrategy :: MonadActionRO m => Ability -> m (Strategy CmdSerTakeTime) + st <- chase aid True + return $! scaleFreq 30 $ bestVariant st + aStrategy :: Ability -> m (Strategy CmdTakeTimeSer) aStrategy Ability.Track = track aid - aStrategy Ability.Heal = return mzero -- TODO - aStrategy Ability.Flee = return mzero -- TODO - aStrategy Ability.Melee | Just foeAid <- mfAid = melee aid fpos foeAid - aStrategy Ability.Melee = return mzero - aStrategy Ability.Pickup | not foeVisible && lootHere bpos = pickup aid - aStrategy Ability.Pickup = return mzero - aStrategy Ability.Wander = wander aid + aStrategy Ability.Heal = return reject -- TODO + aStrategy Ability.Flee = return reject -- TODO + aStrategy Ability.Melee | foeVisible = melee aid + aStrategy Ability.Melee = return reject + aStrategy Ability.Displace = displace aid + aStrategy Ability.Pickup | not foeVisible && lootHere bpos + || hasNoWeapon && lootIsWeapon = pickup aid + aStrategy Ability.Pickup = return reject + aStrategy Ability.Wander = chase aid False aStrategy ab = assert `failure` "unexpected ability" - `twith`(ab, actorAbilities) + `twith`(ab, actorAbs) sumS abis = do fs <- mapM aStrategy abis - return $ msum fs + return $! msum fs sumF abis = do fs <- mapM aFrequency abis - return $ msum fs + return $! msum fs combineDistant as = fmap liftFrequency $ sumF as sumPrefix <- sumS prefix comDistant <- combineDistant distant sumSuffix <- sumS suffix - return $ sumPrefix .| comDistant .| sumSuffix - -- Wait until friends sidestep; ensures the strategy is never empty. - -- TODO: try to switch leader away before that (we already - -- switch him afterwards) - .| waitBlockNow aid + return $! sumPrefix .| comDistant .| sumSuffix + -- Wait until friends sidestep; ensures strategy is never empty. + -- TODO: try to switch leader away before that (we already + -- switch him afterwards) + .| waitBlockNow aid -- | A strategy to always just wait. -waitBlockNow :: ActorId -> Strategy CmdSerTakeTime +waitBlockNow :: ActorId -> Strategy CmdTakeTimeSer waitBlockNow aid = returN "wait" $ WaitSer aid --- | Strategy for dumb missiles. -track :: MonadActionRO m => ActorId -> m (Strategy CmdSerTakeTime) +-- | Strategy for a dumb missile or a strongly hurled actor. +track :: MonadActionRO m => ActorId -> m (Strategy CmdTakeTimeSer) track aid = do - cops <- getsState scops - b@Actor{bpos, bpath, blid} <- getsState $ getActorBody aid - lvl <- getLevel blid - let clearPath = returN "ClearPathSer" $ SetPathSer aid [] - strat = case bpath of - Nothing -> reject - Just [] -> assert `failure` "null path" `twith` (aid, b) - -- TODO: instead let server do this in MoveSer, abort, handle in loop - Just (d : _) | not $ accessibleDir cops lvl bpos d -> clearPath - Just lv -> returN "SetPathSer" $ SetPathSer aid lv - return strat + btrajectory <- getsState $ btrajectory . getActorBody aid + return $! if isNothing btrajectory + then reject + else returN "SetTrajectorySer" $ SetTrajectorySer aid -- TODO: (most?) animals don't pick up. Everybody else does. -pickup :: MonadActionRO m => ActorId -> m (Strategy CmdSerTakeTime) +-- TODO: pick up best weapons first +pickup :: MonadActionRO m => ActorId -> m (Strategy CmdTakeTimeSer) pickup aid = do body@Actor{bpos, blid} <- getsState $ getActorBody aid lvl <- getLevel blid @@ -219,107 +332,191 @@ Just ((iid, k), _) -> do -- pick up first item item <- getsState $ getItemBody iid let l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing - return $ case assignLetter iid l body of - Just l2 -> returN "pickup" $ PickupSer aid iid k l2 + return $! case assignLetter iid l body of + Just _ -> returN "pickup" $ PickupSer aid iid k Nothing -> returN "pickup" $ WaitSer aid -- TODO - return actionPickup + return $! actionPickup -- Everybody melees in a pinch, even though some prefer ranged attacks. -melee :: MonadActionRO m - => ActorId -> Point -> ActorId -> m (Strategy CmdSerTakeTime) -melee aid fpos foeAid = do - Actor{bpos, blid} <- getsState $ getActorBody aid - Level{lxsize} <- getLevel blid - let foeAdjacent = adjacent lxsize bpos fpos -- MeleeDistant - return $ foeAdjacent .=> returN "melee" (MeleeSer aid foeAid) +melee :: MonadClient m => ActorId -> m (Strategy CmdTakeTimeSer) +melee aid = do + b <- getsState $ getActorBody aid + fact <- getsState $ \s -> sfactionD s EM.! bfid b + mtgtMPath <- getsClient $ EM.lookup aid . stargetD + str1 <- case mtgtMPath of + Just (_, Just (_ : q : _, (goal, _))) -> do + -- We prefer the goal (e.g., when no accessible, but adjacent), + -- but accept @q@ even if it's only a blocking enemy position. + let maim = if adjacent (bpos b) goal then Just goal + else if adjacent (bpos b) q then Just q + else Nothing -- MeleeDistant + mBlocker <- case maim of + Nothing -> return Nothing + Just aim -> getsState $ posToActor aim (blid b) + case mBlocker of + Just ((aid2, _), _) -> do + -- No problem if there are many projectiles at the spot. We just + -- attack the first one. + body2 <- getsState $ getActorBody aid2 + if isAtWar fact (bfid body2) then + return $! returN "melee in the way" (MeleeSer aid aid2) + else return reject + Nothing -> return reject + _ -> return reject -- probably no path to the foe, if any + -- TODO: depending on actor kind, sometimes move this in strategy + -- to a place after movement + if not $ nullStrategy str1 then return str1 else do + Level{lxsize, lysize} <- getLevel $ blid b + allFoes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid b) + let vic = vicinity lxsize lysize $ bpos b + adjFoes = filter ((`elem` vic) . bpos . snd) allFoes + -- TODO: prioritize somehow + freq = uniformFreq "melee adjacent" $ map (MeleeSer aid . fst) adjFoes + return $ liftFrequency freq -- Fast monsters don't pay enough attention to features. -triggerFreq :: MonadActionRO m - => ActorId -> m (Frequency CmdSerTakeTime) +triggerFreq :: MonadClient m => ActorId -> m (Frequency CmdTakeTimeSer) triggerFreq aid = do cops@Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops - b@Actor{bpos, blid, bfid, boldpos} <- getsState $ getActorBody aid - fact <- getsState $ \s -> sfactionD s EM.! bfid - lvl <- getLevel blid - let spawn = isSpawnFact cops fact - t = lvl `at` bpos + dungeon <- getsState sdungeon + explored <- getsClient sexplored + b <- getsState $ getActorBody aid + fact <- getsState $ \s -> sfactionD s EM.! bfid b + lvl <- getLevel $ blid b + unexploredD <- unexploredDepth + s <- getState + let unexploredCurrent = ES.notMember (blid b) explored + allExplored = ES.size explored == EM.size dungeon + isHero = isHeroFact cops fact + t = lvl `at` bpos b feats = TileKind.tfeature $ okind t ben feat = case feat of - F.Cause Effect.Escape | spawn -> 0 -- spawners lose if they escape + F.Cause (Effect.Ascend k) -> -- change levels sensibly, in teams + let expBenefit = + if unexploredCurrent + then 0 -- don't leave the level until explored + else if unexploredD (signum k) (blid b) + then 1000 + else if unexploredD (- signum k) (blid b) + then 0 -- wait for stairs in the opposite direciton + else if lescape lvl + then 0 -- all explored, stay on the escape level + else 2 -- no escape anywhere, switch levels occasionally + (lid2, pos2) = whereTo (blid b) (bpos b) k dungeon + actorsThere = posToActors pos2 lid2 s + in if boldpos b == bpos b -- probably used stairs last turn + && boldlid b == lid2 -- in the opposite direction + then 0 -- avoid trivial loops (pushing, being pushed, etc.) + else case actorsThere of + [] -> expBenefit + [((_, body), _)] | not (bproj body) + && isAtWar fact (bfid body) -> + min 1 expBenefit -- push the enemy if no better option + _ -> 0 -- projectiles or non-enemies + F.Cause ef@Effect.Escape{} -> + -- Only heroes escape but they first explore all for high score. + if not (isHero && allExplored) then 0 else effectToBenefit cops b ef F.Cause ef -> effectToBenefit cops b ef _ -> 0 benFeat = zip (map ben feats) feats - -- Probably recently switched levels or was pushed to another level. - -- Do not repeatedly switch levels or push each other between levels. - -- Consequently, AI won't dive many levels down with linked staircases. - -- TODO: beware of stupid monsters that backtrack and so occupy stairs. - recentlyAscended = bpos == boldpos - -- Too fast to notice and use features. - fast = bspeed b > speedNormal - if recentlyAscended || fast then - return mzero - else - return $ toFreq "triggerFreq" $ [ (benefit, TriggerSer aid (Just feat)) - | (benefit, feat) <- benFeat - , benefit > 0 ] + return $! toFreq "triggerFreq" $ [ (benefit, TriggerSer aid (Just feat)) + | (benefit, feat) <- benFeat + , benefit > 0 ] -- Actors require sight to use ranged combat and intelligence to throw -- or zap anything else than obvious physical missiles. -rangedFreq :: MonadActionRO m - => Discovery -> ActorId -> Point -> m (Frequency CmdSerTakeTime) -rangedFreq disco aid fpos = do +rangedFreq :: MonadClient m + => ActorId -> m (Frequency CmdTakeTimeSer) +rangedFreq aid = do cops@Kind.COps{ coactor=Kind.Ops{okind} - , coitem=Kind.Ops{okind=iokind} + , coitem=coitem@Kind.Ops{okind=iokind} , corule - , cotile } <- getsState scops + btarget <- getsClient $ getTarget aid b@Actor{bkind, bpos, bfid, blid, bbag, binv} <- getsState $ getActorBody aid - lvl@Level{lxsize, lysize} <- getLevel blid - let mk = okind bkind - tis = lvl `atI` bpos - fact <- getsState $ \s -> sfactionD s EM.! bfid - foes <- getsState $ actorNotProjList (isAtWar fact) blid - let foesAdj = foesAdjacent lxsize lysize bpos foes - posClear pos1 = Tile.hasFeature cotile F.Clear (lvl `at` pos1) - as <- getsState $ actorList (const True) blid - -- TODO: also don't throw if any pos on path is visibly not accessible - -- from previous (and tweak eps in bla to make it accessible). - -- Also don't throw if target not in range. - s <- getState + mfpos <- aidTgtToPos aid blid btarget + case (btarget, mfpos) of + (Just TEnemy{}, Just fpos) -> do + disco <- getsClient sdisco + itemD <- getsState sitemD + lvl@Level{lxsize, lysize} <- getLevel blid + let mk = okind bkind + tis = lvl `atI` bpos + fact <- getsState $ \s -> sfactionD s EM.! bfid + foes <- getsState $ actorNotProjList (isAtWar fact) blid + let foesAdj = foesAdjacent lxsize lysize bpos foes + (steps, eps) <- makePath b fpos + let permitted = (if aiq mk >= 10 then ritemProject else ritemRanged) + $ Kind.stdRuleset corule + itemReaches item = + let lingerPercent = isLingering coitem disco item + toThrow = maybe 0 (itoThrow . iokind) $ jkind disco item + speed = speedFromWeight (jweight item) toThrow + range = rangeFromSpeed speed + totalRange = lingerPercent * range `div` 100 + in steps <= totalRange -- probably enough range + -- TODO: make sure itoThrow identified after a single throw + getItemB iid = + fromMaybe (assert `failure` "item body not found" + `twith` (iid, itemD)) $ EM.lookup iid itemD + throwFreq bag multi container = + [ (- benefit * multi, + ProjectSer aid fpos eps iid (container iid)) + | (iid, i) <- map (\iid -> (iid, getItemB iid)) + $ EM.keys bag + , let benefit = + case jkind disco i of + Nothing -> -- TODO: (undefined, 0) --- for now, cheating + effectToBenefit cops b (jeffect i) + Just _ki -> + let _kik = iokind _ki + _unneeded = isymbol _kik + in effectToBenefit cops b (jeffect i) + , benefit < 0 + , jsymbol i `elem` permitted + , itemReaches i ] + freq = + if asight mk -- ProjectBlind + && not foesAdj -- ProjectBlockFoes + -- ProjectAimOnself, ProjectBlockActor, ProjectBlockTerrain + -- and no actors or obstracles along the path + && steps == chessDist bpos fpos + then toFreq "throwFreq" + $ throwFreq bbag 4 (actorContainer aid binv) + ++ throwFreq tis 8 (const $ CFloor blid bpos) + else toFreq "throwFreq: not possible" [] + return $! freq + _ -> return $! toFreq "throwFreq: no enemy target" [] + +-- TODO: finetune eps +-- | Counts the number of steps until the projectile would hit +-- an actor or obstacle. +makePath :: MonadClient m => Actor -> Point -> m (Int, Int) +makePath body fpos = do + cops <- getsState scops + lvl@Level{lxsize, lysize} <- getLevel (blid body) + bs <- getsState $ actorNotProjList (const True) (blid body) let eps = 0 - bl = bla lxsize lysize eps bpos fpos -- TODO:make an arg of projectGroupItem - permitted = (if aiq mk >= 10 then ritemProject else ritemRanged) - $ Kind.stdRuleset corule - throwFreq bag multi container = - [ (- benefit * multi, - ProjectSer aid fpos eps iid (container iid)) - | (iid, i) <- map (\iid -> (iid, getItemBody iid s)) - $ EM.keys bag - , let benefit = - case jkind disco i of - Nothing -> -- TODO: (undefined, 0) --- for now, cheating - effectToBenefit cops b (jeffect i) - Just _ki -> - let _kik = iokind _ki - _unneeded = isymbol _kik - in effectToBenefit cops b (jeffect i) - , benefit < 0 - , jsymbol i `elem` permitted ] - return $ toFreq "throwFreq" $ - case bl of - Just (pos1 : _) -> - if not foesAdj -- ProjectBlockFoes - && asight mk - && posClear pos1 -- ProjectBlockTerrain - && unoccupied as pos1 -- ProjectBlockActor - then throwFreq bbag 3 (actorContainer aid binv) - ++ throwFreq tis 6 (const $ CFloor blid bpos) - else [] - _ -> [] -- ProjectAimOnself + mbl = bla lxsize lysize eps (bpos body) fpos + case mbl of + Just bl@(pos1:_) -> do + let noActor p = any ((== p) . bpos) bs + case break noActor bl of + (flies, hits : _) -> do + let blRest = flies ++ [hits] + blZip = zip (bpos body : blRest) blRest + blAccess = takeWhile (uncurry $ accessible cops lvl) blZip + mab <- getsState $ posToActor pos1 (blid body) + if maybe True (bproj . snd . fst) mab then + return $ (length blAccess, eps) + else return (0, eps) -- ProjectBlockActor + _ -> assert `failure` (body, fpos, bl) + Just [] -> assert `failure` (body, fpos) + Nothing -> return (0, eps) -- ProjectAimOnself -- Tools use requires significant intelligence and sometimes literacy. toolsFreq :: MonadActionRO m - => Discovery -> ActorId -> m (Frequency CmdSerTakeTime) + => Discovery -> ActorId -> m (Frequency CmdTakeTimeSer) toolsFreq disco aid = do cops@Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops b@Actor{bkind, bpos, blid, bbag, binv} <- getsState $ getActorBody aid @@ -340,152 +537,97 @@ Just _ki -> effectToBenefit cops b $ jeffect i , benefit > 0 , jsymbol i `elem` mastered ] - return $ toFreq "useFreq" $ + return $! toFreq "useFreq" $ useFreq bbag 1 (actorContainer aid binv) ++ useFreq tis 2 (const $ CFloor blid bpos) --- TODO: express fully in MonadActionRO --- TODO: separate out bumping into solid tiles --- TODO: also close doors; then stupid members of the party won't see them, --- but it's assymetric warfare: rather harm humans than help party members --- | AI finds interesting moves in the absense of visible foes. --- This strategy can be null (e.g., if the actor is blocked by friends). -moveStrategy :: MonadActionRO m - => Kind.COps -> ActorId -> State -> Maybe (Point, Bool) - -> m (Strategy Vector) -moveStrategy cops aid s mFoe = - return $ case mFoe of - -- Target set and we chase the foe or his last position or another target. - Just (fpos, _) -> - let towardsFoe = - let tolerance | adjacent lxsize bpos fpos = 0 - | otherwise = 1 - foeDir = towards lxsize bpos fpos - in only (\x -> euclidDistSq lxsize foeDir x <= tolerance) - in if fpos == bpos - then reject - else towardsFoe - $ if foeVisible - then moveClear -- enemies in sight, don't waste time for doors - .| moveOpenable - else moveOpenable -- no enemy in sight, explore doors - .| moveClear - Nothing -> - let smells = - map (map fst) - $ groupBy ((==) `on` snd) - $ sortBy (flip compare `on` snd) - $ filter (\(_, sm) -> sm > timeZero) - $ map (\x -> - let sml = EM.findWithDefault - timeZero (bpos `shift` x) lsmell - in (x, sml `timeAdd` timeNegate ltime)) - sensible - in asmell mk .=> foldr ((.|) - . liftFrequency - . uniformFreq "smell k") reject smells - .| moveOpenable -- no enemy in sight, explore doors - .| moveClear - where - Kind.COps{cotile, coactor=Kind.Ops{okind}} = cops - lvl@Level{lsmell, lxsize, lysize, ltime} = sdungeon s EM.! blid - Actor{bkind, bpos, boldpos, bfid, blid} = getActorBody aid s - mk = okind bkind - lootHere x = not $ EM.null $ lvl `atI` x - onlyLoot = onlyMoves lootHere - interestHere x = let t = lvl `at` x - ts = map (lvl `at`) $ vicinity lxsize lysize x - in Tile.hasFeature cotile F.Exit t - -- Blind actors tend to reveal/forget repeatedly. - || asight mk && Tile.hasFeature cotile F.Suspect t - -- Lit indirectly. E.g., a room entrance. - || (not (Tile.hasFeature cotile F.Lit t) - && (x == bpos || accessible cops lvl x bpos) - && any (Tile.hasFeature cotile F.Lit) ts) - onlyInterest = onlyMoves interestHere - bdirAI | bpos == boldpos = Nothing - | otherwise = Just $ towards lxsize boldpos bpos - onlyKeepsDir k = - only (\x -> maybe True (\d -> euclidDistSq lxsize d x <= k) bdirAI) - onlyKeepsDir_9 = only (\x -> maybe True (\d -> neg x /= d) bdirAI) - foeVisible = fmap snd mFoe == Just True - -- TODO: aiq 16 leads to robotic, repetitious, looping movement; - -- either base it off some new stat or wait until pathfinding, - -- which will eliminate the loops - moveIQ | foeVisible = onlyKeepsDir_9 moveRandomly -- danger, be flexible - | otherwise = - aiq mk > 15 .=> onlyKeepsDir 0 moveRandomly - .| aiq mk > 10 .=> onlyKeepsDir 1 moveRandomly - .| aiq mk > 5 .=> onlyKeepsDir 2 moveRandomly - .| onlyKeepsDir_9 moveRandomly - interestFreq | interestHere bpos = - -- Don't detour towards an interest if already on one. - mzero - | otherwise = - -- Prefer interests, but don't exclude other focused moves. - scaleFreq 10 $ bestVariant $ onlyInterest $ onlyKeepsDir 2 moveRandomly - interestIQFreq = interestFreq `mplus` bestVariant moveIQ - moveClear = - onlyMoves (not . bumpableHere cops lvl foeVisible (asight mk)) moveFreely - moveOpenable = - onlyMoves (bumpableHere cops lvl foeVisible (asight mk)) moveFreely - -- Ignore previously ignored loot, to prevent repetition. - moveNewLoot = onlyLoot (onlyKeepsDir 2 moveRandomly) - moveFreely = moveNewLoot - .| liftFrequency interestIQFreq - .| moveIQ -- @bestVariant moveIQ@ may be excluded elsewhere - .| moveRandomly - onlyMoves :: (Point -> Bool) -> Strategy Vector -> Strategy Vector - onlyMoves p = only (\x -> p (bpos `shift` x)) - moveRandomly :: Strategy Vector - moveRandomly = liftFrequency $ uniformFreq "moveRandomly" sensible - accessibleHere = accessible cops lvl bpos - fact = sfactionD s EM.! bfid - friends = actorList (not . isAtWar fact) blid s - noFriends | asight mk = unoccupied friends - | otherwise = const True - isSensible l = noFriends l - && (accessibleHere l - || bumpableHere cops lvl foeVisible (asight mk) l) - sensible = filter (isSensible . (bpos `shift`)) (moves lxsize) - -bumpableHere :: Kind.COps -> Level -> Bool -> Bool -> Point -> Bool -bumpableHere Kind.COps{cotile} lvl foeVisible asight pos = - let t = lvl `at` pos -- cannot hold items, so OK - in Tile.openable cotile t - || -- Try to find hidden doors only if no foe in sight and not blind. - -- Blind actors forget their search results too quickly. - asight && not foeVisible && Tile.hasFeature cotile F.Suspect t +displace :: MonadClient m => ActorId -> m (Strategy CmdTakeTimeSer) +displace aid = do + mtgtMPath <- getsClient $ EM.lookup aid . stargetD + str <- case mtgtMPath of + Just (_, Just (p : q : _, _)) -> displaceTowards aid p q + _ -> return reject -- goal reached + Traversable.mapM (moveOrRunAid True aid) str -chase :: MonadActionRO m - => ActorId -> (Point, Bool) -> m (Strategy CmdSerTakeTime) -chase aid foe@(_, foeVisible) = do +-- TODO: perhaps modify target when actually moving, not when +-- producing the strategy, even if it's a unique choice in this case. +displaceTowards :: MonadClient m + => ActorId -> Point -> Point -> m (Strategy Vector) +displaceTowards aid source target = do cops <- getsState scops - -- Target set and we chase the foe or offer null strategy if we can't. - -- The foe is visible, or we remember his last position. - let mFoe = Just foe - fight = not foeVisible -- don't pick fights if the real foe is close - s <- getState - str <- moveStrategy cops aid s mFoe - if fight - then Traversable.mapM (moveRunAid False aid) str - else Traversable.mapM (moveRunAid True aid) str + b <- getsState $ getActorBody aid + assert (source == bpos b && adjacent source target) skip + lvl <- getsState $ (EM.! blid b) . sdungeon + if boldpos b /= target -- avoid trivial loops + && accessible cops lvl source target then do + mBlocker <- getsState $ posToActors target (blid b) + case mBlocker of + [] -> return reject + [((aid2, _), _)] -> do + mtgtMPath <- getsClient $ EM.lookup aid2 . stargetD + case mtgtMPath of + Just (tgt, Just (p : q : rest, (goal, len))) + | q == source && p == target -> do + let newTgt = Just (tgt, Just (q : rest, (goal, len - 1))) + modifyClient $ \cli -> + cli {stargetD = EM.alter (const $ newTgt) aid (stargetD cli)} + return $! returN "displace friend" $ displacement source target + Just _ -> return reject + Nothing -> + return $! returN "displace other" $ displacement source target + _ -> return reject -- many projectiles, can't displace + else return reject -wander :: MonadActionRO m - => ActorId -> m (Strategy CmdSerTakeTime) -wander aid = do - cops <- getsState scops - -- Target set, but we don't chase the foe, e.g., because we are blocked - -- or we cannot chase at all. - let mFoe = Nothing - s <- getState - str <- moveStrategy cops aid s mFoe - Traversable.mapM (moveRunAid False aid) str +chase :: MonadClient m => ActorId -> Bool -> m (Strategy CmdTakeTimeSer) +chase aid foeVisible = do + mtgtMPath <- getsClient $ EM.lookup aid . stargetD + str <- case mtgtMPath of + Just (_, Just (p : q : _, (goal, _))) -> moveTowards aid p q goal + _ -> return reject -- goal reached + if foeVisible -- don't pick fights, but displace, if the real foe is close + then Traversable.mapM (moveOrRunAid True aid) str + else Traversable.mapM (moveOrRunAid False aid) str +moveTowards :: MonadClient m + => ActorId -> Point -> Point -> Point -> m (Strategy Vector) +moveTowards aid source target goal = do + cops@Kind.COps{coactor=Kind.Ops{okind}, cotile} <- getsState scops + b <- getsState $ getActorBody aid + assert (source == bpos b && adjacent source target) skip + lvl <- getsState $ (EM.! blid b) . sdungeon + fact <- getsState $ (EM.! bfid b) . sfactionD + friends <- getsState $ actorList (not . isAtWar fact) $ blid b + let _mk = okind $ bkind b + noFriends = unoccupied friends + -- Was: + -- noFriends | asight mk = unoccupied friends + -- | otherwise = const True + -- but this should be implemented on the server or, if not, + -- restricted to AI-only factions (e.g., animals). + -- Otherwise human players are tempted to tweak their AI clients + -- (as soon as we let them register their AI clients with the server). + accessibleHere = accessible cops lvl source + bumpableHere p = + let t = lvl `at` p + in Tile.isOpenable cotile t || Tile.isSuspect cotile t + enterableHere p = accessibleHere p || bumpableHere p + if noFriends target && enterableHere target then + return $! returN "moveTowards adjacent" $ displacement source target + else do + let goesBack v = v == displacement source (boldpos b) + nonincreasing p = chessDist source goal >= chessDist p goal + isSensible p = nonincreasing p && noFriends p && enterableHere p + sensible = [ ((goesBack v, chessDist p goal), v) + | v <- moves, let p = source `shift` v, isSensible p ] + sorted = sortBy (comparing fst) sensible + groups = map (map snd) $ groupBy ((==) `on` fst) sorted + freqs = map (liftFrequency . uniformFreq "moveTowards") groups + return $! foldr (.|) reject freqs + -- | Actor moves or searches or alters or attacks. Displaces if @run@. -moveRunAid :: MonadActionRO m - => Bool -> ActorId -> Vector -> m CmdSerTakeTime -moveRunAid run source dir = do +moveOrRunAid :: MonadActionRO m + => Bool -> ActorId -> Vector -> m CmdTakeTimeSer +moveOrRunAid run source dir = do cops@Kind.COps{cotile} <- getsState scops sb <- getsState $ getActorBody source let lid = blid sb @@ -497,33 +639,35 @@ -- which gives a partial information (actors can be invisible), -- as opposed to accessibility (and items) which are always accurate -- (tiles can't be invisible). - tgt <- getsState $ posToActor tpos lid - case tgt of - Just target | run -> -- can be a foe, as well as a friend + tgts <- getsState $ posToActors tpos lid + case tgts of + [((target, _), _)] | run -> -- can be a foe, as well as a friend if accessible cops lvl spos tpos then -- Displacing requires accessibility. - return $ DisplaceSer source target + return $! DisplaceSer source target else -- If cannot displace, hit. No DisplaceAccess. - return $ MeleeSer source target - Just target -> -- can be a foe, as well as a friend + return $! MeleeSer source target + ((target, _), _) : _ -> -- can be a foe, as well as a friend (e.g., proj.) + -- No problem if there are many projectiles at the spot. We just + -- attack the first one. -- Attacking does not require full access, adjacency is enough. - return $ MeleeSer source target - Nothing -> do -- move or search or alter + return $! MeleeSer source target + [] -> do -- move or search or alter if accessible cops lvl spos tpos then -- Movement requires full access. - return $ MoveSer source dir + return $! MoveSer source dir -- The potential invisible actor is hit. else if not $ EM.null $ lvl `atI` tpos then -- This is, e.g., inaccessible open door with an item in it. assert `failure` "AI causes AlterBlockItem" `twith` (run, source, dir) - else if not (Tile.hasFeature cotile F.Walkable t) -- not implied - && (Tile.hasFeature cotile F.Suspect t - || Tile.openable cotile t - || Tile.closable cotile t - || Tile.changeable cotile t) then + else if not (Tile.isWalkable cotile t) -- not implied + && (Tile.isSuspect cotile t + || Tile.isOpenable cotile t + || Tile.isClosable cotile t + || Tile.isChangeable cotile t) then -- No access, so search and/or alter the tile. - return $ AlterSer source tpos Nothing + return $! AlterSer source tpos Nothing else -- Boring tile, no point bumping into it, do WaitSer if really idle. assert `failure` "AI causes MoveNothing or AlterNothing" @@ -535,7 +679,6 @@ effectToBenefit :: Kind.COps -> Actor -> Effect.Effect Int -> Int effectToBenefit Kind.COps{coactor=Kind.Ops{okind}} b eff = let kind = okind $ bkind b - deep k = signum k == signum (fromEnum $ blid b) in case eff of Effect.NoEffect -> 0 (Effect.Heal p) -> 10 * min p (Random.maxDice (ahp kind) - bhp b) @@ -548,6 +691,5 @@ Effect.ApplyPerfume -> 0 Effect.Regeneration{} -> 0 -- bigger benefit from carrying around Effect.Searching{} -> 0 - (Effect.Ascend k) | deep k -> 500 -- AI likes to explore deep down - Effect.Ascend{} -> 1 - Effect.Escape -> 1000 -- AI wants to win + Effect.Ascend{} -> 0 -- change levels sensibly, in teams + Effect.Escape{} -> 10000 -- AI wants to win; spawners to guard diff --git a/Game/LambdaHack/Common/Ability.hs b/Game/LambdaHack/Common/Ability.hs --- a/Game/LambdaHack/Common/Ability.hs +++ b/Game/LambdaHack/Common/Ability.hs @@ -10,10 +10,11 @@ -- that any actor picks each turn, depending on the actor's characteristics -- and his environment. data Ability = - Track -- ^ move along a set path, if any, meleeing any opponents + Track -- ^ move along a set trajectory, if any, meleeing any opponents | Heal -- ^ heal if almost dead | Flee -- ^ flee if almost dead | Melee -- ^ melee target + | Displace -- ^ switch places with a friend | Pickup -- ^ gather items, if no foes visible | Trigger -- ^ trigger a feature | Ranged -- ^ attack the visible target opponent at range, some of the time diff --git a/Game/LambdaHack/Common/Action.hs b/Game/LambdaHack/Common/Action.hs --- a/Game/LambdaHack/Common/Action.hs +++ b/Game/LambdaHack/Common/Action.hs @@ -10,9 +10,7 @@ , serverSaveName ) where -import Control.Monad.Writer.Strict (WriterT, lift) import qualified Data.EnumMap.Strict as EM -import Data.Monoid import Game.LambdaHack.Common.AtomicCmd import Game.LambdaHack.Common.Faction @@ -24,13 +22,6 @@ getState :: m State getsState :: (State -> a) -> m a -instance (Monoid a, MonadActionRO m) => MonadActionRO (WriterT a m) where - getState = lift getState - getsState = lift . getsState - -instance MonadActionRO m => Show (WriterT a m b) where - show _ = "an action" - class MonadActionRO m => MonadAction m where modifyState :: (State -> State) -> m () putState :: State -> m () @@ -48,7 +39,7 @@ nUI :: MonadActionRO m => m Int nUI = do factionD <- getsState sfactionD - return $ length $ filter (playerUI . gplayer) $ EM.elems factionD + return $! length $ filter (playerUI . gplayer) $ EM.elems factionD serverSaveName :: String serverSaveName = "server.sav" diff --git a/Game/LambdaHack/Common/Actor.hs b/Game/LambdaHack/Common/Actor.hs --- a/Game/LambdaHack/Common/Actor.hs +++ b/Game/LambdaHack/Common/Actor.hs @@ -11,9 +11,10 @@ , ItemBag, ItemInv, InvChar(..), ItemDict, ItemRev , allLetters, assignLetter, letterLabel, letterRange, rmFromBag -- * Assorted - , ActorDict, smellTimeout, mapActorItems_ + , ActorDict, smellTimeout, mapActorItems_, checkAdjacent ) where +import Control.Exception.Assert.Sugar import Data.Binary import Data.Char import qualified Data.EnumMap.Strict as EM @@ -37,7 +38,6 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ActorKind -import Control.Exception.Assert.Sugar -- | A unique identifier of an actor in the dungeon. newtype ActorId = ActorId Int @@ -52,24 +52,25 @@ -- they are usually modified temporarily, but tend to return -- to the original value from @ActorKind@ over time. E.g., HP. data Actor = Actor - { bkind :: !(Kind.Id ActorKind) -- ^ the kind of the actor - , bsymbol :: !Char -- ^ individual map symbol - , bname :: !Text -- ^ individual name - , bcolor :: !Color.Color -- ^ individual map color - , bspeed :: !Speed -- ^ individual speed - , bhp :: !Int -- ^ current hit points - , bpath :: !(Maybe [Vector]) -- ^ path the actor is forced to travel - , bpos :: !Point -- ^ current position - , boldpos :: !Point -- ^ previous position - , blid :: !LevelId -- ^ current level - , bbag :: !ItemBag -- ^ items carried - , binv :: !ItemInv -- ^ map from letters to items - , bletter :: !InvChar -- ^ next inventory letter - , btime :: !Time -- ^ absolute time of next action - , bwait :: !Time -- ^ last bracing expires at this time - , bfid :: !FactionId -- ^ to which faction the actor belongs - , bproj :: !Bool -- ^ is a projectile? (shorthand only, - -- this can be deduced from bkind) + { bkind :: !(Kind.Id ActorKind) -- ^ the kind of the actor + , bsymbol :: !Char -- ^ individual map symbol + , bname :: !Text -- ^ individual name + , bcolor :: !Color.Color -- ^ individual map color + , bspeed :: !Speed -- ^ individual speed + , bhp :: !Int -- ^ current hit points + , btrajectory :: !(Maybe [Vector]) -- ^ trajectory the actor must travel + , bpos :: !Point -- ^ current position + , boldpos :: !Point -- ^ previous position + , blid :: !LevelId -- ^ current level + , boldlid :: !LevelId -- ^ previous level + , bbag :: !ItemBag -- ^ items carried + , binv :: !ItemInv -- ^ map from letters to items + , bletter :: !InvChar -- ^ next inventory letter + , btime :: !Time -- ^ absolute time of next action + , bwait :: !Bool -- ^ is the actor waiting right now? + , bfid :: !FactionId -- ^ faction the actor belongs to + , bproj :: !Bool -- ^ is a projectile? (shorthand only, + -- this can be deduced from bkind) } deriving (Show, Eq, Ord) @@ -84,8 +85,9 @@ -- Mimics @castDeep@. let n = abs n' depth = abs depth' - scaledDepth = 10 * (n - 1) `div` max 1 (depth - 1) - in chance $ 1%(fromIntegral (50 * (numMonsters - scaledDepth)) `max` 5) + -- On level 1, First 2 monsters appear fast. + scaledDepth = 5 * n `div` depth + in chance $ 1%(fromIntegral (100 * (numMonsters - scaledDepth)) `max` 10) -- | The part of speech describing the actor. partActor :: Actor -> MU.Part @@ -97,13 +99,14 @@ actorTemplate :: Kind.Id ActorKind -> Char -> Text -> Color.Color -> Speed -> Int -> Maybe [Vector] -> Point -> LevelId -> Time -> FactionId -> Bool -> Actor -actorTemplate bkind bsymbol bname bcolor bspeed bhp bpath bpos blid btime +actorTemplate bkind bsymbol bname bcolor bspeed bhp btrajectory bpos blid btime bfid bproj = - let boldpos = bpos + let boldpos = Point 0 0 -- make sure /= bpos, to tell it didn't switch level + boldlid = blid bbag = EM.empty binv = EM.empty bletter = InvChar 'a' - bwait = timeZero + bwait = False in Actor{..} -- | Add time taken by a single step at the actor's current speed. @@ -113,17 +116,13 @@ delta = ticksPerMeter speed in timeAdd time delta --- | Whether an actor is braced for combat this clip. If a foe --- moves just after this actor in the same time moment, the actor won't block, --- because @bwait@ is reset to zero in @ageActorA@ before the condition --- is checked. -braced :: Actor -> Time -> Bool -braced b time = time <= bwait b +-- | Whether an actor is braced for combat this clip. +braced :: Actor -> Bool +braced b = bwait b --- | The actor most probably waited at most a turn ago (unless his speed --- was changed, etc.) -waitedLastTurn :: Actor -> Time -> Bool -waitedLastTurn b time = time <= bwait b +-- | The actor waited last turn. +waitedLastTurn :: Actor -> Bool +waitedLastTurn b = bwait b -- | Checks for the presence of actors in a position. -- Does not check if the tile is walkable. @@ -228,6 +227,9 @@ let is = EM.assocs bbag mapM_ (uncurry f) is +checkAdjacent :: Actor -> Actor -> Bool +checkAdjacent sb tb = blid sb == blid tb && adjacent (bpos sb) (bpos tb) + instance Binary Actor where put Actor{..} = do put bkind @@ -236,10 +238,11 @@ put bcolor put bspeed put bhp - put bpath + put btrajectory put bpos put boldpos put blid + put boldlid put bbag put binv put bletter @@ -254,10 +257,11 @@ bcolor <- get bspeed <- get bhp <- get - bpath <- get + btrajectory <- get bpos <- get boldpos <- get blid <- get + boldlid <- get bbag <- get binv <- get bletter <- get @@ -265,4 +269,4 @@ bwait <- get bfid <- get bproj <- get - return Actor{..} + return $! Actor{..} diff --git a/Game/LambdaHack/Common/ActorState.hs b/Game/LambdaHack/Common/ActorState.hs --- a/Game/LambdaHack/Common/ActorState.hs +++ b/Game/LambdaHack/Common/ActorState.hs @@ -2,13 +2,17 @@ -- but not the 'Action' type. -- TODO: Document an export list after it's rewritten according to #17. module Game.LambdaHack.Common.ActorState - ( actorAssocs, actorList, actorNotProjAssocs, actorNotProjList + ( actorAssocsLvl, actorAssocs, actorList + , actorNotProjAssocsLvl, actorNotProjAssocs, actorNotProjList , calculateTotal, nearbyFreePoints, whereTo - , posToActor, getItemBody, memActor, getActorBody, updateActorBody - , getActorItem, getActorBag, actorContainer, getActorInv + , posToActors, posToActor, getItemBody, memActor + , getActorBody, updateActorBody + , getActorItem, getFloorItem, getActorBag + , actorContainer, actorContainerB, getActorInv , tryFindHeroK, foesAdjacent ) where +import Control.Exception.Assert.Sugar import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES @@ -17,55 +21,67 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction -import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile +import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.TileKind -import Control.Exception.Assert.Sugar -actorAssocs :: (FactionId -> Bool) -> LevelId -> State - -> [(ActorId, Actor)] -actorAssocs p lid s = - mapMaybe (\aid -> let actor = sactorD s EM.! aid +actorAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict + -> [(ActorId, Actor)] +actorAssocsLvl p lvl actorD = + mapMaybe (\aid -> let actor = actorD EM.! aid in if p (bfid actor) then Just (aid, actor) else Nothing) - $ concat $ EM.elems $ lprio $ sdungeon s EM.! lid + $ concat $ EM.elems $ lprio lvl +actorAssocs :: (FactionId -> Bool) -> LevelId -> State + -> [(ActorId, Actor)] +actorAssocs p lid s = + actorAssocsLvl p (sdungeon s EM.! lid) (sactorD s) + actorList :: (FactionId -> Bool) -> LevelId -> State -> [Actor] actorList p lid s = map snd $ actorAssocs p lid s -actorNotProjAssocs :: (FactionId -> Bool) -> LevelId -> State - -> [(ActorId, Actor)] -actorNotProjAssocs p lid s = - mapMaybe (\aid -> let actor = sactorD s EM.! aid +actorNotProjAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict + -> [(ActorId, Actor)] +actorNotProjAssocsLvl p lvl actorD = + mapMaybe (\aid -> let actor = actorD EM.! aid in if not (bproj actor) && p (bfid actor) then Just (aid, actor) else Nothing) - $ concat $ EM.elems $ lprio $ sdungeon s EM.! lid + $ concat $ EM.elems $ lprio lvl +actorNotProjAssocs :: (FactionId -> Bool) -> LevelId -> State + -> [(ActorId, Actor)] +actorNotProjAssocs p lid s = + actorNotProjAssocsLvl p (sdungeon s EM.! lid) (sactorD s) + actorNotProjList :: (FactionId -> Bool) -> LevelId -> State -> [Actor] actorNotProjList p lid s = map snd $ actorNotProjAssocs p lid s --- | Finds an actor at a position on the current level. Perception irrelevant. -posToActor :: Point -> LevelId -> State -> Maybe ActorId -posToActor pos lid s = - let l = posToActors pos lid s - in assert (length l <= 1 `blame` "many actors at the same position" `twith` l) - $ listToMaybe l +-- | Finds an actor at a position on the current level. +posToActor :: Point -> LevelId -> State + -> Maybe ((ActorId, Actor), [(ItemId, Item)]) +posToActor pos lid s = listToMaybe $ posToActors pos lid s -posToActors :: Point -> LevelId -> State -> [ActorId] +posToActors :: Point -> LevelId -> State + -> [((ActorId, Actor), [(ItemId, Item)])] posToActors pos lid s = let as = actorAssocs (const True) lid s - apos = filter (\(_, b) -> bpos b == pos) as - in fmap fst apos + aps = filter (\(_, b) -> bpos b == pos) as + f iid = (iid, getItemBody iid s) + g (aid, b) = ((aid, b), map f $ EM.keys $ bbag b) + l = map g aps + in assert (length l <= 1 || all (bproj . snd . fst) l + `blame` "many actors at the same position" `twith` l) + l nearbyFreePoints :: Kind.Ops TileKind -> (Kind.Id TileKind -> Bool) -> Point -> LevelId -> State @@ -74,7 +90,7 @@ let lvl@Level{lxsize, lysize} = sdungeon s EM.! lid as = actorList (const True) lid s good p = f (lvl `at` p) - && Tile.hasFeature cotile F.Walkable (lvl `at` p) + && Tile.isWalkable cotile (lvl `at` p) && unoccupied as p ps = nub $ start : concatMap (vicinity lxsize lysize) ps in filter good ps @@ -88,9 +104,9 @@ calculateTotal body s = let bs = actorList (== bfid body) (blid body) s bag = EM.unionsWith (+) $ map bbag $ if null bs then [body] else bs - heroItem = map (\(iid, k) -> (getItemBody iid s, k)) - $ EM.assocs bag - in (bag, sum $ map itemPrice heroItem) + items = map (\(iid, k) -> (getItemBody iid s, k)) + $ EM.assocs bag + in (bag, sum $ map itemPrice items) -- | Price an item, taking count into consideration. itemPrice :: (Item, Int) -> Int @@ -127,17 +143,16 @@ whereTo :: LevelId -- ^ level of the stairs -> Point -- ^ position of the stairs -> Int -- ^ jump up this many levels - -> State -- ^ game state + -> Dungeon -- ^ current game dungeon -> (LevelId, Point) -- ^ target level and the position of its receiving stairs -whereTo lid pos k s = assert (k /= 0) $ - let dungeon = sdungeon s - lvl = dungeon EM.! lid +whereTo lid pos k dungeon = assert (k /= 0) $ + let lvl = dungeon EM.! lid stairs = (if k < 0 then snd else fst) (lstair lvl) defaultStairs = 0 -- for ascending via, e.g., spells mindex = elemIndex pos stairs i = fromMaybe defaultStairs mindex - in case ascendInBranch dungeon lid k of + in case ascendInBranch dungeon k lid of [] | isNothing mindex -> (lid, pos) -- spell fizzles [] -> assert `failure` "no dungeon level to go to" `twith` (lid, pos, k) ln : _ -> let lvlTgt = dungeon EM.! ln @@ -170,6 +185,16 @@ Just (l, _) -> CActor aid l Nothing -> assert `failure` "item not in inventory" `twith` (aid, binv, iid) +actorContainerB :: ActorId -> Actor -> ItemId -> Item -> Maybe Container +actorContainerB aid body iid item = + case find ((== iid) . snd) $ EM.assocs (binv body) of + Just (l, _) -> Just $ CActor aid l + Nothing -> + let l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing + in case assignLetter iid l body of + Just l2 -> Just $ CActor aid l2 + Nothing -> Nothing + getActorInv :: ActorId -> State -> ItemInv getActorInv aid s = binv $ getActorBody aid s @@ -179,6 +204,11 @@ getActorItem aid s = let f iid = (iid, getItemBody iid s) in map f $ EM.keys $ getActorBag aid s + +getFloorItem :: LevelId -> Point -> State -> [(ItemId, Item)] +getFloorItem lid pos s = + let f iid = (iid, getItemBody iid s) + in map f $ EM.keys $ sdungeon s EM.! lid `atI` pos getItemBody :: ItemId -> State -> Item getItemBody iid s = diff --git a/Game/LambdaHack/Common/Animation.hs b/Game/LambdaHack/Common/Animation.hs --- a/Game/LambdaHack/Common/Animation.hs +++ b/Game/LambdaHack/Common/Animation.hs @@ -1,52 +1,82 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | Screen frames and animations. module Game.LambdaHack.Common.Animation - ( Attr(..), defAttr, AttrChar(..) - , SingleFrame(..), emptySingleFrame, xsizeSingleFrame, ysizeSingleFrame + ( SingleFrame(..), decodeLine, encodeLine + , overlayOverlay, xsizeSingleFrame, ysizeSingleFrame , Animation, Frames, renderAnim, restrictAnim , twirlSplash, blockHit, blockMiss, deathBody, swapPlaces, fadeout , AcFrame(..) , DebugModeCli(..), defDebugModeCli ) where -import Control.Arrow ((***)) +import Control.Exception.Assert.Sugar import Control.Monad import Data.Binary import Data.Bits import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import qualified Data.List as L +import Data.Int (Int32) +import Data.List import Data.Maybe import Data.Monoid -import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U +import GHC.Generics (Generic) import Game.LambdaHack.Common.Color +import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.Random +type ScreenLine = U.Vector Int32 + +decodeLine :: ScreenLine -> [AttrChar] +decodeLine v = map (toEnum . fromIntegral) $ G.toList v + +encodeLine :: [AttrChar] -> ScreenLine +encodeLine l = G.fromList $ map (fromIntegral . fromEnum) l + -- | The data sufficent to draw a single game screen frame. --- --- The fields are not strict, because sometimes frames are not used, --- e.g., when a keypress discards all frames not yet drawn and displayed. data SingleFrame = SingleFrame - { sfLevel :: [[AttrChar]] -- ^ content of the screen, line by line - , sfTop :: Text -- ^ an extra line to show at the top - , sfBottom :: Text -- ^ an extra line to show at the bottom + { sfLevel :: ![ScreenLine] -- ^ screen, from top to bottom, line by line + , sfTop :: !Overlay -- ^ some extra lines to show over the top + , sfBottom :: ![ScreenLine] -- ^ some extra lines to show at the bottom + , sfBlank :: !Bool -- ^ display only @sfTop@, on blank screen } deriving (Eq, Show) -instance Binary SingleFrame where - put SingleFrame{..} = do - put sfLevel - put sfTop - put sfBottom - get = do - sfLevel <- get - sfTop <- get - sfBottom <- get - return SingleFrame{..} +-- | Overlays the @sfTop@ and @sfBottom@ fields onto the @sfLevel@ field. +-- The resulting frame has empty @sfTop@ and @sfBottom@. +-- To be used by simple frontends that don't display overlays +-- in separate windows/panes/scrolled views. +overlayOverlay :: SingleFrame -> SingleFrame +overlayOverlay sf@SingleFrame{..} = + let lxsize = xsizeSingleFrame sf + lysize = ysizeSingleFrame sf + emptyLine = encodeLine + $ replicate lxsize (Color.AttrChar Color.defAttr ' ') + canvasLength = if sfBlank then lysize + 3 else lysize + 1 + canvas | sfBlank = replicate canvasLength emptyLine + | otherwise = emptyLine : sfLevel + topTrunc = map (truncateMsg lxsize) $ overlay sfTop + topLayer = if length topTrunc <= canvasLength + then topTrunc + else take (canvasLength - 1) topTrunc + ++ ["--a portion of the text trimmed--"] + addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t) + f layerLine canvasLine = encodeLine + $ addAttr layerLine + ++ drop (T.length layerLine) (decodeLine canvasLine) + picture = zipWith f topLayer canvas + bottomLines = if sfBlank then [] else sfBottom + newLevel = picture ++ drop (length picture) canvas ++ bottomLines + in SingleFrame { sfLevel = newLevel + , sfTop = emptyOverlay + , sfBottom = [] + , sfBlank } -- | Animation is a list of frame modifications to play one by one, -- where each modification if a map from positions to level map symbols. @@ -56,12 +86,9 @@ -- | Sequences of screen frames, including delays. type Frames = [Maybe SingleFrame] -emptySingleFrame :: SingleFrame -emptySingleFrame = SingleFrame{sfLevel = [], sfTop = "", sfBottom = ""} - xsizeSingleFrame :: SingleFrame -> X xsizeSingleFrame SingleFrame{sfLevel=[]} = 0 -xsizeSingleFrame SingleFrame{sfLevel=line : _} = length line +xsizeSingleFrame SingleFrame{sfLevel=line : _} = G.length line ysizeSingleFrame :: SingleFrame -> X ysizeSingleFrame SingleFrame{sfLevel} = length sfLevel @@ -69,17 +96,21 @@ -- | Render animations on top of a screen frame. renderAnim :: X -> Y -> SingleFrame -> Animation -> Frames renderAnim lxsize lysize basicFrame (Animation anim) = - let modifyFrame SingleFrame{sfLevel = levelOld, ..} am = + let modifyFrame SingleFrame{sfLevel = []} _ = + assert `failure` (lxsize, lysize, basicFrame, anim) + modifyFrame SingleFrame{sfLevel = levelOld, ..} am = let fLine y lineOld = let f l (x, acOld) = - let pos = toPoint lxsize (PointXY (x, y)) + let pos = Point x y !ac = fromMaybe acOld $ EM.lookup pos am in ac : l - in L.foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld)) - sfLevel = -- Fully evaluated. + in foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld)) + sfLevel = -- fully evaluated inside let f l (y, lineOld) = let !line = fLine y lineOld in line : l - in L.foldl' f [] (zip [lysize-1,lysize-2..0] (reverse levelOld)) - in Just SingleFrame{..} + in map encodeLine + $ foldl' f [] (zip [lysize-1,lysize-2..0] + $ reverse $ map decodeLine levelOld) + in Just SingleFrame{..} -- a thunk within Just in map (modifyFrame basicFrame) anim blank :: Maybe AttrChar @@ -186,17 +217,17 @@ in EM.findWithDefault ' ' k edge rollFrame n = do r <- random - let l = [ ( PointXY (if topRight then x else xbound - x, y) - , fadeChar r n x y ) + let l = [ ( Point (if topRight then x else xbound - x) y + , AttrChar defAttr $ fadeChar r n x y ) | x <- [0..xbound] , y <- [max 0 (ybound - (n - x) `div` 2)..ybound] ++ [0..min ybound ((n - xbound + x) `div` 2)] ] - return $ EM.fromList $ map (toPoint lxsize *** AttrChar defAttr) l + return $! EM.fromList l startN = if out then 3 else 1 fs = [startN..3 * lxsize `divUp` 4 + 2] as <- mapM rollFrame $ if out then fs else reverse fs - return $ Animation as + return $! Animation as data AcFrame = AcConfirm !SingleFrame @@ -205,20 +236,6 @@ | AcDelay deriving (Show, Eq) -instance Binary AcFrame where - put (AcConfirm fr) = putWord8 0 >> put fr - put (AcRunning fr) = putWord8 1 >> put fr - put (AcNormal fr) = putWord8 2 >> put fr - put AcDelay = putWord8 3 - get = do - tag <- getWord8 - case tag of - 0 -> liftM AcConfirm get - 1 -> liftM AcRunning get - 2 -> liftM AcNormal get - 3 -> return AcDelay - _ -> fail "no parse (AcFrame)" - data DebugModeCli = DebugModeCli { sfont :: !(Maybe String) -- ^ Font to use for the main game window. @@ -237,14 +254,18 @@ -- ^ Don't show any animations. , snewGameCli :: !Bool -- ^ Start a new game, overwriting the save file. + , sdifficultyCli :: !Int + -- ^ The difficulty level for all UI clients. , ssavePrefixCli :: !(Maybe String) -- ^ Prefix of the save game file. , sfrontendStd :: !Bool -- ^ Whether to use the stdout/stdin frontend. + , sfrontendNo :: !Bool + -- ^ Whether to use no frontend at all (for benchmarking, etc.). , sdbgMsgCli :: !Bool -- ^ Show clients' internal debug messages. } - deriving (Show, Eq) + deriving (Show, Eq, Generic) defDebugModeCli :: DebugModeCli defDebugModeCli = DebugModeCli @@ -254,30 +275,38 @@ , snoMore = False , snoAnim = Nothing , snewGameCli = False + , sdifficultyCli = 0 , ssavePrefixCli = Nothing , sfrontendStd = False + , sfrontendNo = False , sdbgMsgCli = False } -instance Binary DebugModeCli where - put DebugModeCli{..} = do - put sfont - put smaxFps - put snoDelay - put snoMore - put snoAnim - put snewGameCli - put ssavePrefixCli - put sfrontendStd - put sdbgMsgCli +instance Binary AcFrame where + put (AcConfirm fr) = putWord8 0 >> put fr + put (AcRunning fr) = putWord8 1 >> put fr + put (AcNormal fr) = putWord8 2 >> put fr + put AcDelay = putWord8 3 get = do - sfont <- get - smaxFps <- get - snoDelay <- get - snoMore <- get - snoAnim <- get - snewGameCli <- get - ssavePrefixCli <- get - sfrontendStd <- get - sdbgMsgCli <- get - return DebugModeCli{..} + tag <- getWord8 + case tag of + 0 -> liftM AcConfirm get + 1 -> liftM AcRunning get + 2 -> liftM AcNormal get + 3 -> return AcDelay + _ -> fail "no parse (AcFrame)" + +instance Binary SingleFrame where + put SingleFrame{..} = do + put sfLevel + put sfTop + put sfBottom + put sfBlank + get = do + sfLevel <- get + sfTop <- get + sfBottom <- get + sfBlank <- get + return $! SingleFrame{..} + +instance Binary DebugModeCli diff --git a/Game/LambdaHack/Common/AtomicCmd.hs b/Game/LambdaHack/Common/AtomicCmd.hs --- a/Game/LambdaHack/Common/AtomicCmd.hs +++ b/Game/LambdaHack/Common/AtomicCmd.hs @@ -59,14 +59,14 @@ | LoseItemA !ItemId !Item !Int !Container -- Move actors and items. | MoveActorA !ActorId !Point !Point - | WaitActorA !ActorId !Time !Time + | WaitActorA !ActorId !Bool !Bool | DisplaceActorA !ActorId !ActorId | MoveItemA !ItemId !Int !Container !Container -- Change actor attributes. | AgeActorA !ActorId !Time | HealActorA !ActorId !Int | HasteActorA !ActorId !Speed - | PathActorA !ActorId !(Maybe [Vector]) !(Maybe [Vector]) + | TrajectoryActorA !ActorId !(Maybe [Vector]) !(Maybe [Vector]) | ColorActorA !ActorId !Color.Color !Color.Color -- Change faction attributes. | QuitFactionA !FactionId !(Maybe Actor) !(Maybe Status) !(Maybe Status) @@ -85,7 +85,7 @@ | AgeGameA !Time | DiscoverA !LevelId !Point !ItemId !(Kind.Id ItemKind) | CoverA !LevelId !Point !ItemId !(Kind.Id ItemKind) - | PerceptionA !LevelId !PerActor !PerActor + | PerceptionA !LevelId !Perception !Perception | RestartA !FactionId !Discovery !FactionPers !State !DebugModeCli !Text | RestartServerA !State | ResumeA !FactionId !FactionPers @@ -138,7 +138,7 @@ AgeActorA aid t -> Just $ AgeActorA aid (timeNegate t) HealActorA aid n -> Just $ HealActorA aid (-n) HasteActorA aid delta -> Just $ HasteActorA aid (speedNegate delta) - PathActorA aid fromPath toPath -> Just $ PathActorA aid toPath fromPath + TrajectoryActorA aid fromT toT -> Just $ TrajectoryActorA aid toT fromT ColorActorA aid fromCol toCol -> Just $ ColorActorA aid toCol fromCol QuitFactionA fid mb fromSt toSt -> Just $ QuitFactionA fid mb toSt fromSt LeadFactionA fid source target -> Just $ LeadFactionA fid target source diff --git a/Game/LambdaHack/Common/AtomicPos.hs b/Game/LambdaHack/Common/AtomicPos.hs --- a/Game/LambdaHack/Common/AtomicPos.hs +++ b/Game/LambdaHack/Common/AtomicPos.hs @@ -7,6 +7,7 @@ , seenAtomicCli, seenAtomicSer ) where +import Control.Exception.Assert.Sugar import qualified Data.EnumSet as ES import Game.LambdaHack.Common.Action @@ -18,7 +19,6 @@ import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point -import Control.Exception.Assert.Sugar -- All functions here that take an atomic action are executed -- in the state just before the action is executed. @@ -55,65 +55,61 @@ -- contradict state) if the visibility is lower. posCmdAtomic :: MonadActionRO m => CmdAtomic -> m PosAtomic posCmdAtomic cmd = case cmd of - CreateActorA _ body _ -> - return $ PosFidAndSight (bfid body) (blid body) [bpos body] - DestroyActorA _ body _ -> - return $ PosFidAndSight (bfid body) (blid body) [bpos body] + CreateActorA _ body _ -> posProjBody body + DestroyActorA _ body _ -> posProjBody body CreateItemA _ _ _ c -> singleContainer c DestroyItemA _ _ _ c -> singleContainer c - SpotActorA _ body _ -> - return $ PosFidAndSight (bfid body) (blid body) [bpos body] - LoseActorA _ body _ -> - return $ PosFidAndSight (bfid body) (blid body) [bpos body] + SpotActorA _ body _ -> posProjBody body + LoseActorA _ body _ -> posProjBody body SpotItemA _ _ _ c -> singleContainer c LoseItemA _ _ _ c -> singleContainer c MoveActorA aid fromP toP -> do (lid, _) <- posOfAid aid - return $ PosSight lid [fromP, toP] + return $! PosSight lid [fromP, toP] WaitActorA aid _ _ -> singleAid aid DisplaceActorA source target -> do (slid, sp) <- posOfAid source (tlid, tp) <- posOfAid target - return $ assert (slid == tlid) $ PosSight slid [sp, tp] + return $! assert (slid == tlid) $ PosSight slid [sp, tp] MoveItemA _ _ c1 c2 -> do -- works even if moved between positions (lid1, p1) <- posOfContainer c1 (lid2, p2) <- posOfContainer c2 - return $ assert (lid1 == lid2) $ PosSight lid1 [p1, p2] + return $! assert (lid1 == lid2) $ PosSight lid1 [p1, p2] AgeActorA aid _ -> singleAid aid HealActorA aid _ -> singleAid aid HasteActorA aid _ -> singleAid aid - PathActorA aid _ _ -> singleAid aid + TrajectoryActorA aid _ _ -> singleAid aid ColorActorA aid _ _ -> singleAid aid QuitFactionA{} -> return PosAll - LeadFactionA fid _ _ -> return $ PosFidAndSer fid + LeadFactionA fid _ _ -> return $! PosFidAndSer fid DiplFactionA{} -> return PosAll - AlterTileA lid p _ _ -> return $ PosSight lid [p] + AlterTileA lid p _ _ -> return $! PosSight lid [p] SearchTileA aid p _ _ -> do (lid, pos) <- posOfAid aid - return $ PosSight lid [pos, p] + return $! PosSight lid [pos, p] SpotTileA lid ts -> do let ps = map fst ts - return $ PosSight lid ps + return $! PosSight lid ps LoseTileA lid ts -> do let ps = map fst ts - return $ PosSight lid ps - AlterSmellA lid p _ _ -> return $ PosSmell lid [p] + return $! PosSight lid ps + AlterSmellA lid p _ _ -> return $! PosSmell lid [p] SpotSmellA lid sms -> do let ps = map fst sms - return $ PosSmell lid ps + return $! PosSmell lid ps LoseSmellA lid sms -> do let ps = map fst sms - return $ PosSmell lid ps - AgeLevelA lid _ -> return $ PosSight lid [] + return $! PosSmell lid ps + AgeLevelA lid _ -> return $! PosSight lid [] AgeGameA _ -> return PosAll - DiscoverA lid p _ _ -> return $ PosSight lid [p] - CoverA lid p _ _ -> return $ PosSight lid [p] + DiscoverA lid p _ _ -> return $! PosSight lid [p] + CoverA lid p _ _ -> return $! PosSight lid [p] PerceptionA{} -> return PosNone - RestartA fid _ _ _ _ _ -> return $ PosFid fid + RestartA fid _ _ _ _ _ -> return $! PosFid fid RestartServerA _ -> return PosSer - ResumeA fid _ -> return $ PosFid fid + ResumeA fid _ -> return $! PosFid fid ResumeServerA _ -> return PosSer - KillExitA fid -> return $ PosFid fid + KillExitA fid -> return $! PosFid fid SaveBkpA -> return PosAll MsgAllA{} -> return PosAll @@ -122,44 +118,50 @@ StrikeD source target _ _ -> do (slid, sp) <- posOfAid source (tlid, tp) <- posOfAid target - return $ assert (slid == tlid) $ PosSight slid [sp, tp] + return $! assert (slid == tlid) $ PosSight slid [sp, tp] RecoilD source target _ _ -> do (slid, sp) <- posOfAid source (tlid, tp) <- posOfAid target - return $ assert (slid == tlid) $ PosSight slid [sp, tp] + return $! assert (slid == tlid) $ PosSight slid [sp, tp] ProjectD aid _ -> singleAid aid CatchD aid _ -> singleAid aid ActivateD aid _ -> singleAid aid CheckD aid _ -> singleAid aid TriggerD aid p _ -> do (lid, pa) <- posOfAid aid - return $ PosSight lid [pa, p] + return $! PosSight lid [pa, p] ShunD aid p _ -> do (lid, pa) <- posOfAid aid - return $ PosSight lid [pa, p] + return $! PosSight lid [pa, p] EffectD aid _ -> singleAid aid - MsgFidD fid _ -> return $ PosFid fid + MsgFidD fid _ -> return $! PosFid fid MsgAllD _ -> return PosAll - DisplayPushD fid -> return $ PosFid fid - DisplayDelayD fid -> return $ PosFid fid - RecordHistoryD fid -> return $ PosFid fid + DisplayPushD fid -> return $! PosFid fid + DisplayDelayD fid -> return $! PosFid fid + RecordHistoryD fid -> return $! PosFid fid +posProjBody :: Monad m => Actor -> m PosAtomic +posProjBody body = return $! + if bproj body + then PosSight (blid body) [bpos body] + else PosFidAndSight (bfid body) (blid body) [bpos body] + singleAid :: MonadActionRO m => ActorId -> m PosAtomic singleAid aid = do b <- getsState $ getActorBody aid - return $ PosFidAndSight (bfid b) (blid b) [bpos b] + return $! PosSight (blid b) [bpos b] singleContainer :: MonadActionRO m => Container -> m PosAtomic singleContainer c = do (lid, p) <- posOfContainer c - return $ PosSight lid [p] + return $! PosSight lid [p] -- Determines is a command resets FOV. @Nothing@ means it always does. -- A list of faction means it does for each of the factions. -- This is only an optimization to save perception and spot/lose computation. -- -- Invariant: if @resetsFovAtomic@ determines a faction does not need --- to reset Fov, perception (@perActor@ to be precise, @psmell@ is irrelevant) +-- to reset Fov, perception (@ptotal@ to be precise, @psmell@ is irrelevant) -- of that faction does not change upon recomputation. Otherwise, -- save/restore would change game state. resetsFovAtomic :: MonadActionRO m => CmdAtomic -> m (Maybe [FactionId]) @@ -227,10 +229,10 @@ seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool seenAtomicCli knowEvents fid per posAtomic = case posAtomic of - PosSight _ ps -> knowEvents || all (`ES.member` totalVisible per) ps + PosSight _ ps -> all (`ES.member` totalVisible per) ps || knowEvents PosFidAndSight fid2 _ ps -> - knowEvents || fid == fid2 || all (`ES.member` totalVisible per) ps - PosSmell _ ps -> knowEvents || all (`ES.member` smellVisible per) ps + fid == fid2 || all (`ES.member` totalVisible per) ps || knowEvents + PosSmell _ ps -> all (`ES.member` smellVisible per) ps || knowEvents PosFid fid2 -> fid == fid2 PosFidAndSer fid2 -> fid == fid2 PosSer -> False diff --git a/Game/LambdaHack/Common/AtomicSem.hs b/Game/LambdaHack/Common/AtomicSem.hs --- a/Game/LambdaHack/Common/AtomicSem.hs +++ b/Game/LambdaHack/Common/AtomicSem.hs @@ -7,11 +7,11 @@ ) where import Control.Arrow (second) +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import Data.List -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState @@ -23,6 +23,7 @@ import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point +import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time @@ -46,7 +47,7 @@ AgeActorA aid t -> ageActorA aid t HealActorA aid n -> healActorA aid n HasteActorA aid delta -> hasteActorA aid delta - PathActorA aid fromPath toPath -> pathActorA aid fromPath toPath + TrajectoryActorA aid fromT toT -> trajectoryActorA aid fromT toT ColorActorA aid fromCol toCol -> colorActorA aid fromCol toCol QuitFactionA fid mbody fromSt toSt -> quitFactionA fid mbody fromSt toSt LeadFactionA fid source target -> leadFactionA fid source target @@ -64,8 +65,8 @@ AgeGameA t -> ageGameA t DiscoverA{} -> return () -- Server keeps all atomic comands so the semantics CoverA{} -> return () -- of inverses has to be reasonably inverse. - PerceptionA _ outPA inPA -> - assert (not (EM.null outPA && EM.null inPA)) $ return () + PerceptionA _ outPer inPer -> + assert (not (nullPer outPer && nullPer inPer)) skip RestartA fid sdisco sfper s _ _ -> restartA fid sdisco sfper s RestartServerA s -> restartServerA s ResumeA{} -> return () @@ -80,7 +81,8 @@ createActorA aid body ais = do -- Add actor to @sactorD@. let f Nothing = Just body - f (Just b) = assert `failure` "actor already added" `twith` (aid, body, b) + f (Just b) = assert `failure` "actor already added" + `twith` (aid, body, b) modifyState $ updateActorD $ EM.alter f aid -- Add actor to @sprio@. let g Nothing = Just [aid] @@ -203,7 +205,7 @@ modifyState $ updateActorBody aid $ \body -> body {bpos = toP, boldpos = fromP} -waitActorA :: MonadAction m => ActorId -> Time -> Time -> m () +waitActorA :: MonadAction m => ActorId -> Bool -> Bool -> m () waitActorA aid fromWait toWait = assert (fromWait /= toWait) $ do b <- getsState $ getActorBody aid assert (fromWait == bwait b `blame` "unexpected waited actor time" @@ -245,11 +247,7 @@ body <- getsState $ getActorBody aid ais <- getsState $ getActorItem aid destroyActorA aid body ais - let newBody = body { btime = timeAdd (btime body) t - , bwait = if bwait body <= btime body - then timeZero -- reset old waiting time - else bwait body -- keep new waiting time - } + let newBody = body {btime = timeAdd (btime body) t} createActorA aid newBody ais healActorA :: MonadAction m => ActorId -> Int -> m () @@ -260,17 +258,18 @@ hasteActorA aid delta = assert (delta /= speedZero) $ do modifyState $ updateActorBody aid $ \ b -> let newSpeed = speedAdd (bspeed b) delta - in assert (newSpeed >= speedZero `blame` "actor slowed below zero" - `twith` (aid, delta, bspeed b, newSpeed)) $ - b {bspeed = newSpeed} + in assert (newSpeed >= speedZero + `blame` "actor slowed below zero" + `twith` (aid, delta, b, newSpeed)) + $ b {bspeed = newSpeed} -pathActorA :: MonadAction m +trajectoryActorA :: MonadAction m => ActorId -> Maybe [Vector] -> Maybe [Vector] -> m () -pathActorA aid fromPath toPath = assert (fromPath /= toPath) $ do +trajectoryActorA aid fromT toT = assert (fromT /= toT) $ do body <- getsState $ getActorBody aid - assert (fromPath == bpath body `blame` "unexpected actor path" - `twith` (aid, fromPath, toPath, body)) skip - modifyState $ updateActorBody aid $ \b -> b {bpath = toPath} + assert (fromT == btrajectory body `blame` "unexpected actor trajectory" + `twith` (aid, fromT, toT, body)) skip + modifyState $ updateActorBody aid $ \b -> b {btrajectory = toT} colorActorA :: MonadAction m => ActorId -> Color.Color -> Color.Color -> m () @@ -319,7 +318,10 @@ modifyState $ updateFaction $ EM.adjust (adj fid1) fid2 -- | Alter an attribute (actually, the only, the defining attribute) --- of a visible tile. This is similar to e.g., @PathActorA@. +-- of a visible tile. This is similar to e.g., @TrajectoryActorA@. +-- We do not modify @lclear@ here, because we can't keep track of +-- alterations to unknown tiles. The server would need to send @lclear@ +-- updates for each invisible tile alteration that affects it. alterTileA :: MonadAction m => LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind -> m () @@ -332,18 +334,18 @@ -- and it suddenly changes into another tile, -- which at the same time becomes visible (e.g., an open door). -- See 'AtomicSemCli' for how this is reported to the client. - let adj ts = assert (ts Kind.! p == fromTile - || ts Kind.! p == freshClientTile + let adj ts = assert (ts PointArray.! p == fromTile + || ts PointArray.! p == freshClientTile `blame` "unexpected altered tile kind" - `twith` (lid, p, fromTile, toTile, ts Kind.! p)) - $ ts Kind.// [(p, toTile)] + `twith` (lid, p, fromTile, toTile, ts PointArray.! p)) + $ ts PointArray.// [(p, toTile)] updateLevel lid $ updateTile adj case (Tile.isExplorable cotile fromTile, Tile.isExplorable cotile toTile) of (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl + 1} (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl - 1} _ -> return () --- Notice a previously invisible tiles. This is similar to @SpotActorA@, +-- Notice previously invisible tiles. This is similar to @SpotActorA@, -- but done in bulk, because it often involves dozens of tiles pers move. -- We don't check that the tiles at the positions in question are unknown -- to save computation, especially for clients that remember tiles @@ -353,17 +355,17 @@ spotTileA lid ts = assert (not $ null ts) $ do Kind.COps{cotile} <- getsState scops Level{ltile} <- getLevel lid - let adj tileMap = tileMap Kind.// ts + let adj tileMap = tileMap PointArray.// ts updateLevel lid $ updateTile adj let f (p, t2) = do - let t1 = ltile Kind.! p + let t1 = ltile PointArray.! p case (Tile.isExplorable cotile t1, Tile.isExplorable cotile t2) of (False, True) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl+1} (True, False) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl-1} _ -> return () mapM_ f ts --- Stop noticing a previously visible tiles. Unlike @spotTileA@, it verifies +-- Stop noticing previously visible tiles. Unlike @spotTileA@, it verifies -- the state of the tiles before changing them. loseTileA :: MonadAction m => LevelId -> [(Point, Kind.Id TileKind)] -> m () loseTileA lid ts = assert (not $ null ts) $ do @@ -371,9 +373,9 @@ let unknownId = ouniqGroup "unknown space" matches _ [] = True matches tileMap ((p, ov) : rest) = - tileMap Kind.! p == ov && matches tileMap rest + tileMap PointArray.! p == ov && matches tileMap rest tu = map (second (const unknownId)) ts - adj tileMap = assert (matches tileMap ts) $ tileMap Kind.// tu + adj tileMap = assert (matches tileMap ts) $ tileMap PointArray.// tu updateLevel lid $ updateTile adj let f (_, t1) = when (Tile.isExplorable cotile t1) $ @@ -382,21 +384,16 @@ alterSmellA :: MonadAction m => LevelId -> Point -> Maybe Time -> Maybe Time -> m () -alterSmellA lid p _fromSm toSm = do - -- TODO: this rarely crashes when a dominated smelling monster exists: - -- let alt sm = assert (sm == fromSm `blame` "unexpected tile smell" - -- `twith` (lid, p, fromSm, toSm, sm)) toSm - let alt _ = toSm +alterSmellA lid p fromSm toSm = do + let alt sm = assert (sm == fromSm `blame` "unexpected tile smell" + `twith` (lid, p, fromSm, toSm, sm)) toSm updateLevel lid $ updateSmell $ EM.alter alt p spotSmellA :: MonadAction m => LevelId -> [(Point, Time)] -> m () spotSmellA lid sms = assert (not $ null sms) $ do let alt sm Nothing = Just sm - alt sm (Just _) = Just sm --- TODO: a hack to sidestep server not disabling the nose of fresh actors, --- see smellFromActors --- alt sm (Just oldSm) = assert `failure` "smell already added" --- `twith` (lid, sms, sm, oldSm) + alt sm (Just oldSm) = assert `failure` "smell already added" + `twith` (lid, sms, sm, oldSm) f (p, sm) = EM.alter (alt sm) p upd m = foldr f m sms updateLevel lid $ updateSmell upd diff --git a/Game/LambdaHack/Common/ClientCmd.hs b/Game/LambdaHack/Common/ClientCmd.hs --- a/Game/LambdaHack/Common/ClientCmd.hs +++ b/Game/LambdaHack/Common/ClientCmd.hs @@ -47,7 +47,7 @@ CmdAtomicAI cmdA@SpotTileA{} -> debugPlain cmd cmdA CmdAtomicAI cmdA -> debugPretty cmd cmdA CmdQueryAI aid -> debugAid aid "CmdQueryAI" cmd - CmdPingAI -> return $ showT cmd + CmdPingAI -> return $! tshow cmd debugCmdClientUI :: MonadActionRO m => CmdClientUI -> m Text debugCmdClientUI cmd = case cmd of @@ -57,19 +57,19 @@ CmdAtomicUI cmdA -> debugPretty cmd cmdA SfxAtomicUI sfx -> do ps <- posSfxAtomic sfx - return $ showT (cmd, ps) + return $! tshow (cmd, ps) CmdQueryUI aid -> debugAid aid "CmdQueryUI" cmd - CmdPingUI -> return $ showT cmd + CmdPingUI -> return $! tshow cmd debugPretty :: (MonadActionRO m, Show a) => a -> CmdAtomic -> m Text debugPretty cmd cmdA = do ps <- posCmdAtomic cmdA - return $ showT (cmd, ps) + return $! tshow (cmd, ps) debugPlain :: (MonadActionRO m, Show a) => a -> CmdAtomic -> m Text debugPlain cmd cmdA = do ps <- posCmdAtomic cmdA - return $ T.pack $ show (cmd, ps) -- too large for pretty show + return $! T.pack $ show (cmd, ps) -- too large for pretty show data DebugAid a = DebugAid { label :: !Text @@ -88,12 +88,12 @@ else do b <- getsState $ getActorBody aid time <- getsState $ getLocalTime (blid b) - return $ showT DebugAid { label - , cmd - , lid = blid b - , time - , aid - , faction = bfid b } + return $! tshow DebugAid { label + , cmd + , lid = blid b + , time + , aid + , faction = bfid b } -- | Connection channels between the server and a single client. data ChanServer c d = ChanServer @@ -104,7 +104,7 @@ -- | Connections to the human-controlled client of a faction and -- to the AI client for the same faction. type ConnServerFaction = ( Maybe (ChanFrontend, ChanServer CmdClientUI CmdSer) - , ChanServer CmdClientAI CmdSerTakeTime ) + , ChanServer CmdClientAI CmdTakeTimeSer ) -- | Connection information for all factions, indexed by faction identifier. type ConnServerDict = EM.EnumMap FactionId ConnServerFaction diff --git a/Game/LambdaHack/Common/Color.hs b/Game/LambdaHack/Common/Color.hs --- a/Game/LambdaHack/Common/Color.hs +++ b/Game/LambdaHack/Common/Color.hs @@ -9,6 +9,7 @@ ) where import Data.Binary +import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) import qualified Data.Hashable as Hashable import GHC.Generics (Generic) @@ -39,10 +40,6 @@ instance Hashable.Hashable Color -instance Binary Color where - put = putWord8 . toEnum . fromEnum - get = fmap (toEnum . fromEnum) getWord8 - -- | The default colours, to optimize attribute setting. defBG, defFG :: Color defBG = Black @@ -55,14 +52,10 @@ } deriving (Show, Eq, Ord) -instance Binary Attr where - put Attr{..} = do - put fg - put bg - get = do - fg <- get - bg <- get - return Attr{..} +instance Enum Attr where + fromEnum Attr{..} = fromEnum fg + unsafeShiftL (fromEnum bg) 8 + toEnum n = Attr (toEnum $ n .&. (2 ^ (8 :: Int) - 1)) + (toEnum $ unsafeShiftR n 8) -- | The default attribute, to optimize attribute setting. defAttr :: Attr @@ -72,16 +65,12 @@ { acAttr :: !Attr , acChar :: !Char } - deriving (Show, Eq) + deriving (Show, Eq, Ord) -instance Binary AttrChar where - put AttrChar{..} = do - put acAttr - put acChar - get = do - acAttr <- get - acChar <- get - return AttrChar{..} +instance Enum AttrChar where + fromEnum AttrChar{..} = fromEnum acAttr + unsafeShiftL (fromEnum acChar) 16 + toEnum n = AttrChar (toEnum $ n .&. (2 ^ (16 :: Int) - 1)) + (toEnum $ unsafeShiftR n 16) -- | A helper for the terminal frontends that display bright via bold. isBright :: Color -> Bool @@ -136,3 +125,25 @@ _olorToRGB BrMagenta = "#FF55FF" _olorToRGB BrCyan = "#55FFFF" _olorToRGB BrWhite = "#FFFFFF" + +instance Binary Color where + put = putWord8 . toEnum . fromEnum + get = fmap (toEnum . fromEnum) getWord8 + +instance Binary Attr where + put Attr{..} = do + put fg + put bg + get = do + fg <- get + bg <- get + return $! Attr{..} + +instance Binary AttrChar where + put AttrChar{..} = do + put acAttr + put acChar + get = do + acAttr <- get + acChar <- get + return $! AttrChar{..} diff --git a/Game/LambdaHack/Common/ConfigIO.hs b/Game/LambdaHack/Common/ConfigIO.hs deleted file mode 100644 --- a/Game/LambdaHack/Common/ConfigIO.hs +++ /dev/null @@ -1,97 +0,0 @@ --- | Personal game configuration file support. -module Game.LambdaHack.Common.ConfigIO - ( CP, appDataDir, mkConfig, get, getOption, set, getItems, to_string, dump - ) where - -import Control.Exception.Assert.Sugar -import qualified Data.Char as Char -import qualified Data.ConfigFile as CF -import System.Directory -import System.Environment -import System.FilePath - -import Game.LambdaHack.Server.Config - -overrideCP :: CP -> FilePath -> IO CP -overrideCP cp@(CP defCF) cfile = do - cpExists <- doesFileExist cfile - if not cpExists - then return cp - else do - c <- CF.readfile defCF cfile - return $ toCP $ assert `forceEither` c - --- | Read a player configuration file and use it to override --- options from a default config. Currently we can't unset options, --- only override. The default config, passed in argument @configDefault@, --- is expected to come from a default configuration file included via TH. --- The player configuration comes from file @cfile@. -mkConfig :: String -> FilePath -> IO CP -mkConfig configDefault cfile = do - let delComment = map (drop 2) $ lines configDefault - unConfig = unlines delComment - -- Evaluate, to catch config errors ASAP. - !defCF = assert `forceEither` CF.readstring CF.emptyCP unConfig - !defCP = toCP defCF - overrideCP defCP cfile - --- | Personal data directory for the game. Depends on the OS and the game, --- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@. -appDataDir :: IO FilePath -appDataDir = do - progName <- getProgName - let name = takeWhile Char.isAlphaNum progName - getAppUserDataDirectory name - --- | Dumps the current configuration to a file. -dump :: Config -> FilePath -> IO () -dump Config{configSelfString} fn = do - current <- getCurrentDirectory - let path = current fn - writeFile path configSelfString - --- | Simplified setting of an option in a given section. Overwriting forbidden. -set :: CP -> CF.SectionSpec -> CF.OptionSpec -> String -> CP -set (CP conf) s o v = - if CF.has_option conf s o - then assert `failure`"overwritten config option" `twith` (s, o) - else CP $ assert `forceEither` CF.set conf s o v - --- | The content of the configuration file. It's parsed --- in a case sensitive way (unlike by default in ConfigFile). -newtype CP = CP CF.ConfigParser - -instance Show CP where - show (CP conf) = show $ CF.to_string conf - --- | Switches all names to case sensitive (unlike by default in --- the "ConfigFile" library) and wraps in the constructor. -toCP :: CF.ConfigParser -> CP -toCP cf = CP $ cf {CF.optionxform = id} - --- | A simplified access to an option in a given section, --- with simple error reporting (no internal errors are caught nor hidden). --- If there is no such option, gives Nothing. -getOption :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> Maybe a -getOption (CP conf) s o = - if CF.has_option conf s o - then Just $ assert `forceEither` CF.get conf s o - else Nothing - --- | Simplified access to an option in a given section. --- Fails if the option is not present. -get :: CF.Get_C a => CP -> CF.SectionSpec -> CF.OptionSpec -> a -get (CP conf) s o = - if CF.has_option conf s o - then assert `forceEither` CF.get conf s o - else assert `failure` "unknown CF option" `twith` (s, o, CF.to_string conf) - --- | An association list corresponding to a section. Fails if no such section. -getItems :: CP -> CF.SectionSpec -> [(String, String)] -getItems (CP conf) s = - if CF.has_section conf s - then assert `forceEither` CF.items conf s - else assert `failure` "unknown CF section" `twith` (s, CF.to_string conf) - -to_string :: CP -> String -to_string (CP conf) = CF.to_string conf diff --git a/Game/LambdaHack/Common/Effect.hs b/Game/LambdaHack/Common/Effect.hs --- a/Game/LambdaHack/Common/Effect.hs +++ b/Game/LambdaHack/Common/Effect.hs @@ -5,6 +5,7 @@ ( Effect(..), effectTrav, effectToSuffix ) where +import Control.Exception.Assert.Sugar import qualified Control.Monad.State as St import Data.Binary import qualified Data.Hashable as Hashable @@ -13,7 +14,6 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Random -import Control.Exception.Assert.Sugar -- TODO: document each constructor -- Effects of items, tiles, etc. The type argument represents power. @@ -22,7 +22,7 @@ NoEffect | Heal !Int | Hurt !RollDice !a - | Mindprobe !Int -- the @Int@ is a hack to send the result to clients + | Mindprobe Int -- the @Int@ is a lazy hack to send the result to clients | Dominate | CallFriend !Int | Summon !Int @@ -31,7 +31,7 @@ | Regeneration !a | Searching !a | Ascend !Int - | Escape + | Escape !Int deriving (Show, Read, Eq, Ord, Generic, Functor) instance Hashable.Hashable a => Hashable.Hashable (Effect a) @@ -42,24 +42,24 @@ -- | Transform an effect using a stateful function. effectTrav :: Effect a -> (a -> St.State s b) -> St.State s (Effect b) effectTrav NoEffect _ = return NoEffect -effectTrav (Heal p) _ = return $ Heal p +effectTrav (Heal p) _ = return $! Heal p effectTrav (Hurt dice a) f = do b <- f a - return $ Hurt dice b -effectTrav (Mindprobe x) _ = return $ Mindprobe x + return $! Hurt dice b +effectTrav (Mindprobe x) _ = return $! Mindprobe x effectTrav Dominate _ = return Dominate -effectTrav (CallFriend p) _ = return $ CallFriend p -effectTrav (Summon p) _ = return $ Summon p -effectTrav (CreateItem p) _ = return $ CreateItem p +effectTrav (CallFriend p) _ = return $! CallFriend p +effectTrav (Summon p) _ = return $! Summon p +effectTrav (CreateItem p) _ = return $! CreateItem p effectTrav ApplyPerfume _ = return ApplyPerfume effectTrav (Regeneration a) f = do b <- f a - return $ Regeneration b + return $! Regeneration b effectTrav (Searching a) f = do b <- f a - return $ Searching b -effectTrav (Ascend p) _ = return $ Ascend p -effectTrav Escape _ = return Escape + return $! Searching b +effectTrav (Ascend p) _ = return $! Ascend p +effectTrav (Escape p) _ = return $! Escape p -- | Suffix to append to a basic content name if the content causes the effect. effectToSuff :: Show a => Effect a -> (a -> Text) -> Text @@ -69,7 +69,7 @@ Heal p | p > 0 -> "of healing" <> affixBonus p Heal 0 -> "of bloodletting" Heal p -> "of wounding" <> affixBonus p - Hurt dice t -> "(" <> showT dice <> ")" <> t + Hurt dice t -> "(" <> tshow dice <> ")" <> t Mindprobe{} -> "of soul searching" Dominate -> "of domination" CallFriend p -> "of aid calling" <> affixPower p @@ -81,7 +81,7 @@ Ascend p | p > 0 -> "of ascending" <> affixPower p Ascend p | p < 0 -> "of descending" <> affixPower (- p) Ascend{} -> assert `failure` effect - Escape -> "of escaping" + Escape{} -> "of escaping" effectToSuffix :: Effect Int -> Text effectToSuffix effect = effectToSuff effect affixBonus @@ -90,10 +90,10 @@ affixPower p = case compare p 1 of EQ -> "" LT -> assert `failure` "power less than 1" `twith` p - GT -> " (+" <> showT p <> ")" + GT -> " (+" <> tshow p <> ")" affixBonus :: Int -> Text affixBonus p = case compare p 0 of EQ -> "" - LT -> " (" <> showT p <> ")" - GT -> " (+" <> showT p <> ")" + LT -> " (" <> tshow p <> ")" + GT -> " (+" <> tshow p <> ")" diff --git a/Game/LambdaHack/Common/Faction.hs b/Game/LambdaHack/Common/Faction.hs --- a/Game/LambdaHack/Common/Faction.hs +++ b/Game/LambdaHack/Common/Faction.hs @@ -2,7 +2,7 @@ -- the hero faction battling the monster and the animal factions. module Game.LambdaHack.Common.Faction ( FactionId, FactionDict, Faction(..), Diplomacy(..), Outcome(..), Status(..) - , isSpawnFact, isSummonFact, isAtWar, isAllied + , isHeroFact, isHorrorFact, isSpawnFact, isSummonFact, isAtWar, isAllied ) where import Data.Binary @@ -58,12 +58,22 @@ } deriving (Show, Eq, Ord) --- | Tell whether the faction can spawn actors. -isSpawnFact :: Kind.COps -> Faction -> Bool -isSpawnFact Kind.COps{cofaction=Kind.Ops{okind}} fact = +-- | Tell whether the faction consists of heroes. +isHeroFact :: Kind.COps -> Faction -> Bool +isHeroFact Kind.COps{cofaction=Kind.Ops{okind}} fact = let kind = okind (gkind fact) - in maybe False (> 0) $ lookup "spawn" $ ffreq kind + in maybe False (> 0) $ lookup "hero" $ ffreq kind +-- | Tell whether the faction consists of summoned horrors only. +isHorrorFact :: Kind.COps -> Faction -> Bool +isHorrorFact Kind.COps{cofaction=Kind.Ops{okind}} fact = + let kind = okind (gkind fact) + in maybe False (> 0) $ lookup "horror" $ ffreq kind + +-- | Tell whether the faction can spawn actors. +isSpawnFact :: Faction -> Bool +isSpawnFact fact = playerSpawn (gplayer fact) > 0 + -- | Tell whether actors of the faction can be summoned by items, etc. isSummonFact :: Kind.COps -> Faction -> Bool isSummonFact Kind.COps{cofaction=Kind.Ops{okind}} fact = @@ -95,7 +105,7 @@ gdipl <- get gquit <- get gleader <- get - return Faction{..} + return $! Faction{..} instance Binary Diplomacy where put Unknown = putWord8 0 @@ -138,4 +148,4 @@ stOutcome <- get stDepth <- get stInfo <- get - return Status{..} + return $! Status{..} diff --git a/Game/LambdaHack/Common/Feature.hs b/Game/LambdaHack/Common/Feature.hs --- a/Game/LambdaHack/Common/Feature.hs +++ b/Game/LambdaHack/Common/Feature.hs @@ -10,27 +10,25 @@ import Game.LambdaHack.Common.Effect --- | All possible terrain tile features, some of them parameterized --- or dependent on outside coefficients, e.g., on the tile secrecy value. +-- | All possible terrain tile features. data Feature = Cause !(Effect Int) -- ^ causes the effect when triggered - | OpenTo !Text -- ^ goes from an open to a closed tile when altered - | CloseTo !Text -- ^ goes from a closed to an open tile when altered + | OpenTo !Text -- ^ goes from a closed to an open tile when altered + | CloseTo !Text -- ^ goes from an open to a closed tile when altered | ChangeTo !Text -- ^ alters tile, but does not change walkability | HideAs !Text -- ^ when hidden, looks as a tile of the group | RevealAs !Text -- ^ if secret, can be revealed to belong to the group | Walkable -- ^ actors can walk through | Clear -- ^ actors can see through - | Lit -- ^ is lit with an ambient shine + | Dark -- ^ is not lit with an ambient shine | Suspect -- ^ may not be what it seems (clients only) | Aura !(Effect Int) -- ^ sustains the effect continuously, TODO | Impenetrable -- ^ can never be excavated nor seen through | CanItem -- ^ items can be generated there | CanActor -- ^ actors and stairs can be generated there - | Exit -- ^ is a (not hidden) door, stair, etc. - | Path -- ^ used for visible paths throughout the level + | Trail -- ^ used for visible trails throughout the level deriving (Show, Read, Eq, Ord, Generic) instance Binary Feature diff --git a/Game/LambdaHack/Common/Flavour.hs b/Game/LambdaHack/Common/Flavour.hs --- a/Game/LambdaHack/Common/Flavour.hs +++ b/Game/LambdaHack/Common/Flavour.hs @@ -13,7 +13,6 @@ import Data.Binary import qualified Data.Hashable as Hashable -import qualified Data.List as L import Data.Text (Text) import GHC.Generics (Generic) @@ -33,8 +32,8 @@ -- | Turn a colour set into a flavour set. zipPlain, zipFancy :: [Color] -> [Flavour] -zipPlain = L.map (Flavour False) -zipFancy = L.map (Flavour True) +zipPlain = map (Flavour False) +zipFancy = map (Flavour True) -- | The standard full set of flavours. stdFlav :: [Flavour] diff --git a/Game/LambdaHack/Common/HighScore.hs b/Game/LambdaHack/Common/HighScore.hs --- a/Game/LambdaHack/Common/HighScore.hs +++ b/Game/LambdaHack/Common/HighScore.hs @@ -1,11 +1,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | High score table operations. module Game.LambdaHack.Common.HighScore - ( ScoreTable, empty, register, slideshow + ( ScoreTable, empty, register, highSlideshow ) where import Data.Binary -import qualified Data.List as L import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU @@ -20,36 +19,39 @@ -- | A single score record. Records are ordered in the highscore table, -- from the best to the worst, in lexicographic ordering wrt the fields below. data ScoreRecord = ScoreRecord - { points :: !Int -- ^ the score - , negTime :: !Time -- ^ game time spent (negated, so less better) - , date :: !ClockTime -- ^ date of the last game interruption - , status :: !Status -- ^ reason of the game interruption + { points :: !Int -- ^ the score + , negTime :: !Time -- ^ game time spent (negated, so less better) + , date :: !ClockTime -- ^ date of the last game interruption + , status :: !Status -- ^ reason of the game interruption + , difficulty :: !Int -- ^ difficulty of the game } deriving (Eq, Ord) +-- TODO: move all to Text -- | Show a single high score, from the given ranking in the high score table. showScore :: (Int, ScoreRecord) -> [Text] showScore (pos, score) = let Status{stOutcome, stDepth} = status score died = case stOutcome of - Killed -> "perished on level " ++ show (abs stDepth) ++ "," - Defeated -> "was defeated" - Camping -> "is camping somewhere," - Conquer -> "eliminated all opposition" - Escape -> "emerged victorious" - Restart -> "resigned prematurely" + Killed -> "Perished on level " ++ show (abs stDepth) + Defeated -> "Was defeated" + Camping -> "Camps somewhere" + Conquer -> "Slew all opposition" + Escape -> "Emerged victorious" + Restart -> "Resigned prematurely" curDate = calendarTimeToString . toUTCTime . date $ score - big, lil :: String - big = " " - lil = " " turns = - (negTime score `timeFit` timeTurn) + diff = 5 - difficulty score + diffText :: String + diffText | diff == 5 = "" + | otherwise = printf " (difficulty %d)" diff -- TODO: the spaces at the end are hand-crafted. Remove when display -- of overlays adds such spaces automatically. in map T.pack - [ big - , printf "%4d. %6d This adventuring party %s after %d turns " - pos (points score) died turns - , lil ++ printf "on %s. " curDate + [ "" + , printf "%4d. %6d %s%s" + pos (points score) died diffText + , " " ++ printf "after %d turns on %s." turns curDate ] -- | The list of scores, in decreasing order. @@ -67,8 +69,8 @@ -- Make sure the table doesn't grow too large. insertPos :: ScoreRecord -> ScoreTable -> (ScoreTable, Int) insertPos s (ScoreTable table) = - let (prefix, suffix) = L.span (> s) table - pos = L.length prefix + 1 + let (prefix, suffix) = span (> s) table + pos = length prefix + 1 in (ScoreTable $ prefix ++ [s] ++ take (100 - pos) suffix, pos) -- | Register a new score in a score table. @@ -77,42 +79,45 @@ -> Time -- ^ game time spent -> Status -- ^ reason of the game interruption -> ClockTime -- ^ current date + -> Int -- ^ difficulty level -> Maybe (ScoreTable, Int) -register table total time status@Status{stOutcome} date = - let points = if stOutcome `elem` [Killed, Defeated, Restart] - then (total + 1) `div` 2 - else if stOutcome == Conquer - then let turnsSpent = timeFit time timeTurn - speedup = 10000 - 5 * turnsSpent - bonus = sqrt $ fromIntegral speedup :: Double - in 10 + floor bonus - else total +register table total time status@Status{stOutcome} date difficulty = + let pUnscaled = if stOutcome `elem` [Killed, Defeated, Restart] + then (total + 1) `div` 2 + else if stOutcome == Conquer + then let turnsSpent = timeFit time timeTurn + speedup = 10000 - 5 * turnsSpent + bonus = sqrt $ fromIntegral speedup :: Double + in 10 + floor bonus + else total + points = (round :: Double -> Int) + $ fromIntegral pUnscaled * 1.5 ^^ difficulty negTime = timeNegate time score = ScoreRecord{..} in if points > 0 then Just $ insertPos score table else Nothing -- | Show a screenful of the high scores table. -- Parameter height is the number of (3-line) scores to be shown. -showTable :: ScoreTable -> Int -> Int -> Overlay -showTable (ScoreTable table) start height = +tshowable :: ScoreTable -> Int -> Int -> [Text] +tshowable (ScoreTable table) start height = let zipped = zip [1..] table screenful = take height . drop (start - 1) $ zipped in concatMap showScore screenful ++ [moreMsg] -- | Produce a couple of renderings of the high scores table. -showCloseScores :: Int -> ScoreTable -> Int -> [Overlay] +showCloseScores :: Int -> ScoreTable -> Int -> [[Text]] showCloseScores pos h height = if pos <= height - then [showTable h 1 height] - else [showTable h 1 height, - showTable h (max (height + 1) (pos - height `div` 2)) height] + then [tshowable h 1 height] + else [tshowable h 1 height, + tshowable h (max (height + 1) (pos - height `div` 2)) height] -- | Generate a slideshow with the current and previous scores. -slideshow :: ScoreTable -- ^ current score table - -> Int -- ^ position of the current high score in the table - -> Status -- ^ reason of the game interruption - -> Slideshow -slideshow table pos status = +highSlideshow :: ScoreTable -- ^ current score table + -> Int -- ^ position of the current score in the table + -> Status -- ^ reason of the game interruption + -> Slideshow +highSlideshow table pos status = let (_, nlines) = normalLevelBound -- TODO: query terminal size instead height = nlines `div` 3 (subject, person, msgUnless) = @@ -141,19 +146,21 @@ [ MU.SubjectVerb person MU.Yes subject "award you" , MU.Ordinal pos, "place" , msgUnless ] - in toSlideshow $ map ([msg] ++) $ showCloseScores pos table height + in toSlideshow True $ map ([msg] ++) $ showCloseScores pos table height instance Binary ScoreRecord where - put (ScoreRecord p n (TOD cs cp) s) = do + put (ScoreRecord p n (TOD cs cp) s difficulty) = do put p put n put cs put cp put s + put difficulty get = do p <- get n <- get cs <- get cp <- get s <- get - return (ScoreRecord p n (TOD cs cp) s) + difficulty <- get + return $! ScoreRecord p n (TOD cs cp) s difficulty diff --git a/Game/LambdaHack/Common/HumanCmd.hs b/Game/LambdaHack/Common/HumanCmd.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Common/HumanCmd.hs @@ -0,0 +1,158 @@ +-- | Abstract syntax human player commands. +module Game.LambdaHack.Common.HumanCmd + ( CmdCategory(..), HumanCmd(..), Trigger(..) + , noRemoteHumanCmd, categoryDescription, cmdDescription + ) where + +import Control.Exception.Assert.Sugar +import Data.Text (Text) +import qualified NLP.Miniutter.English as MU + +import qualified Game.LambdaHack.Common.Feature as F +import Game.LambdaHack.Common.Msg +import Game.LambdaHack.Common.Vector + +data CmdCategory = CmdMenu | CmdMove | CmdItem | CmdTgt | CmdMeta | CmdDebug + deriving (Show, Read, Eq) + +categoryDescription :: CmdCategory -> Text +categoryDescription CmdMenu = "Main Menu" +categoryDescription CmdMove = "Movement and terrain alteration" +categoryDescription CmdItem = "Inventory and items" +categoryDescription CmdTgt = "Targeting" +categoryDescription CmdMeta = "Assorted" +categoryDescription CmdDebug = "Debug" + +-- | Abstract syntax of player commands. +data HumanCmd = + -- These usually take time. + Move !Vector + | Run !Vector + | Wait + | Pickup + | Drop + | Project ![Trigger] + | Apply ![Trigger] + | AlterDir ![Trigger] + | TriggerTile ![Trigger] + | StepToTarget + | Resend + -- Below this line, commands do not take time. + | GameRestart !Text + | GameExit + | GameSave + | GameDifficultyCycle + -- Below this line, commands do not notify the server. + | PickLeader !Int + | MemberCycle + | MemberBack + | Inventory + | SelectActor + | SelectNone + | Clear + | Repeat !Int + | Record + | History + | MarkVision + | MarkSmell + | MarkSuspect + | Help + | MainMenu + | Macro !Text ![String] + -- These are mostly related to targeting. + | MoveCursor !Vector !Int + | TgtFloor + | TgtEnemy + | TgtUnknown + | TgtItem + | TgtStair !Bool + | TgtAscend !Int + | EpsIncr !Bool + | TgtClear + | Cancel + | Accept + deriving (Eq, Ord, Show, Read) + +data Trigger = + ApplyItem {verb :: !MU.Part, object :: !MU.Part, symbol :: !Char} + | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature} + | TriggerFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature} + deriving (Show, Read, Eq, Ord) + +-- | Commands that are forbidden on a remote level, because they +-- would usually take time when invoked on one. +-- Note that some commands that take time are not included, +-- because they don't take time in targeting mode. +noRemoteHumanCmd :: HumanCmd -> Bool +noRemoteHumanCmd cmd = case cmd of + Wait -> True + Pickup -> True + Drop -> True + Project{} -> True + Apply{} -> True + AlterDir{} -> True + StepToTarget -> True + Resend -> True + _ -> False + +-- | Description of player commands. +cmdDescription :: HumanCmd -> Text +cmdDescription cmd = case cmd of + Move v -> "move" <+> compassText v + Run v -> "run" <+> compassText v + Wait -> "wait" + Pickup -> "get an object" + Drop -> "drop an object" + Project ts -> triggerDescription ts + Apply ts -> triggerDescription ts + AlterDir ts -> triggerDescription ts + TriggerTile ts -> triggerDescription ts + StepToTarget -> "make one step towards the target" + Resend -> "resend last server command" + + GameRestart t -> "new" <+> t <+> "game" + GameExit -> "save and exit" + GameSave -> "save game" + + GameDifficultyCycle -> "cycle difficulty of the next game" + PickLeader{} -> "pick leader" + MemberCycle -> "cycle among party members on the level" + MemberBack -> "cycle among party members in the dungeon" + Inventory -> "display inventory" + SelectActor -> "select (or deselect) a party member" + SelectNone -> "deselect (or select) all on the level" + Clear -> "clear messages" + Repeat 1 -> "play back last keys" + Repeat n -> "play back last keys" <+> tshow n <+> "times" + Record -> "start recording a macro" + History -> "display player diary" + MarkVision -> "mark visible area" + MarkSmell -> "mark smell" + MarkSuspect -> "mark suspect terrain" + Help -> "display help" + MainMenu -> "display the Main Menu" + Macro t _ -> t + + MoveCursor v 1 -> "move cursor" <+> compassText v + MoveCursor v k -> + "move cursor up to" <+> tshow k <+> "steps" <+> compassText v + TgtFloor -> "cycle targeting mode" + TgtEnemy -> "target enemy" + TgtUnknown -> "target the closest unknown spot" + TgtItem -> "target the closest item" + TgtStair up -> "target the closest stairs" <+> if up then "up" else "down" + TgtAscend k | k == 1 -> "target next shallower level" + TgtAscend k | k >= 2 -> "target" <+> tshow k <+> "levels shallower" + TgtAscend k | k == -1 -> "target next deeper level" + TgtAscend k | k <= -2 -> "target" <+> tshow (-k) <+> "levels deeper" + TgtAscend _ -> assert `failure` "void level change when targeting" + `twith` cmd + EpsIncr True -> "swerve targeting line" + EpsIncr False -> "unswerve targeting line" + TgtClear -> "clear target/cursor" + Cancel -> "cancel action" + Accept -> "accept choice" + +triggerDescription :: [Trigger] -> Text +triggerDescription [] = "trigger a thing" +triggerDescription (t : _) = makePhrase [verb t, object t] diff --git a/Game/LambdaHack/Common/Item.hs b/Game/LambdaHack/Common/Item.hs --- a/Game/LambdaHack/Common/Item.hs +++ b/Game/LambdaHack/Common/Item.hs @@ -6,7 +6,7 @@ -- inventory manangement and items proper. module Game.LambdaHack.Common.Item ( -- * Teh @Item@ type - ItemId, Item(..), jkind, buildItem, newItem, viewItem + ItemId, Item(..), jkind, buildItem, newItem -- * Inventory search , strongestSearch, strongestSword, strongestRegen -- * The item discovery types @@ -15,8 +15,11 @@ , FlavourMap, emptyFlavourMap, dungeonFlavourMap -- * Textual description , partItem, partItemWs, partItemAW + -- * Assorted + , isFragile, isExplosive, isLingering, causeIEffects ) where +import Control.Exception.Assert.Sugar import Control.Monad import Data.Binary import qualified Data.EnumMap.Strict as EM @@ -29,15 +32,14 @@ import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU -import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Effect import Game.LambdaHack.Common.Flavour +import qualified Game.LambdaHack.Common.ItemFeature as IF import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Random import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.RuleKind -import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency -- | A unique identifier of an item in the dungeon. @@ -67,6 +69,7 @@ , jname :: !Text -- ^ individual generic name , jflavour :: !Flavour -- ^ individual flavour , jeffect :: !(Effect Int) -- ^ the effect when activated + , jweight :: !Int -- ^ weight in grams, obvious enough } deriving (Show, Eq, Ord, Generic) @@ -106,20 +109,21 @@ case iflavour kind of [fl] -> fl _ -> flavour EM.! ikChosen + jweight = iweight kind in Item{..} -- | Generate an item based on level. newItem :: Kind.Ops ItemKind -> FlavourMap -> DiscoRev -> Frequency Text -> Int -> Int -> Rnd (Item, Int, ItemKind) -newItem cops@Kind.Ops{opick, okind} flavour discoRev itemFreq lvl depth = do +newItem coitem@Kind.Ops{opick, okind} flavour discoRev itemFreq lvl depth = do itemGroup <- frequency itemFreq let castItem :: Int -> Rnd (Item, Int, ItemKind) castItem 0 | nullFreq itemFreq = assert `failure` "no fallback items" `twith` (itemFreq, lvl, depth) castItem 0 = do let newFreq = setFreq itemFreq itemGroup 0 - newItem cops flavour discoRev newFreq lvl depth + newItem coitem flavour discoRev newFreq lvl depth castItem count = do ikChosen <- fmap (fromMaybe $ assert `failure` itemGroup) $ opick itemGroup (const True) @@ -128,16 +132,15 @@ if jcount == 0 then castItem $ count - 1 else do - effect <- effectTrav (ieffect kind) (castDeep lvl depth) + let kindEffect = case causeIEffects coitem ikChosen of + [] -> NoEffect + eff : _TODO -> eff + effect <- effectTrav kindEffect (castDeep lvl depth) return ( buildItem flavour discoRev ikChosen kind effect , jcount , kind ) castItem 10 --- | Represent an item on the map. -viewItem :: Item -> (Char, Color.Color) -viewItem i = (jsymbol i, flavourToColor $ jflavour i) - -- | Flavours assigned by the server to item kinds, in this particular game. newtype FlavourMap = FlavourMap (EM.EnumMap (Kind.Id ItemKind) Flavour) deriving (Show, Binary) @@ -193,6 +196,40 @@ strongestRegen is = strongestItem is $ \ i -> case jeffect i of Regeneration k -> Just k; _ -> Nothing + +isFragile :: Kind.Ops ItemKind -> Discovery -> Item -> Bool +isFragile Kind.Ops{okind} disco i = + case jkind disco i of + Nothing -> False + Just ik -> + let getTo IF.Fragile _acc = True + getTo IF.Explode{} _acc = True + getTo _ acc = acc + in foldr getTo False $ ifeature $ okind ik + +isExplosive :: Kind.Ops ItemKind -> Discovery -> Item -> Maybe Text +isExplosive Kind.Ops{okind} disco i = + case jkind disco i of + Nothing -> Nothing + Just ik -> + let getTo (IF.Explode cgroup) _acc = Just cgroup + getTo _ acc = acc + in foldr getTo Nothing $ ifeature $ okind ik + +isLingering :: Kind.Ops ItemKind -> Discovery -> Item -> Int +isLingering Kind.Ops{okind} disco i = + case jkind disco i of + Nothing -> 100 + Just ik -> + let getTo (IF.Linger percent) _acc = percent + getTo _ acc = acc + in foldr getTo 100 $ ifeature $ okind ik + +causeIEffects :: Kind.Ops ItemKind -> Kind.Id ItemKind -> [Effect RollDeep] +causeIEffects Kind.Ops{okind} ik = do + let getTo (IF.Cause eff) acc = eff : acc + getTo _ acc = acc + foldr getTo [] $ ifeature $ okind ik -- | The part of speech describing the item. partItem :: Kind.Ops ItemKind -> Discovery -> Item -> (MU.Part, MU.Part) diff --git a/Game/LambdaHack/Common/ItemFeature.hs b/Game/LambdaHack/Common/ItemFeature.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Common/ItemFeature.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | Item features. +module Game.LambdaHack.Common.ItemFeature + ( Feature(..) + ) where + +import Data.Binary +import Data.Text (Text) +import GHC.Generics (Generic) + +import Game.LambdaHack.Common.Effect +import Game.LambdaHack.Common.Random + +-- | All possible item features. +data Feature = + Cause !(Effect RollDeep) -- ^ causes the effect when triggered + | ChangeTo !Text -- ^ changes to this item kind group when altered + | Explode !Text -- ^ explode, producing this group of shrapnel + | Fragile -- ^ breaks even when not hitting an enemy + | Linger !Int -- ^ fly for this percentage of 2 turns + deriving (Show, Eq, Ord, Generic) + +instance Binary Feature diff --git a/Game/LambdaHack/Common/Key.hs b/Game/LambdaHack/Common/Key.hs --- a/Game/LambdaHack/Common/Key.hs +++ b/Game/LambdaHack/Common/Key.hs @@ -1,20 +1,20 @@ +{-# LANGUAGE DeriveGeneric #-} -- | Frontend-independent keyboard input operations. module Game.LambdaHack.Common.Key ( Key(..), handleDir, dirAllMoveKey - , moveBinding, keyTranslate, Modifier(..), KM(..), showKM, escKey + , moveBinding, mkKM, keyTranslate, Modifier(..), KM(..), showKM, escKey ) where +import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.Char as Char -import qualified Data.List as L import Data.Text (Text) import qualified Data.Text as T +import GHC.Generics (Generic) import Prelude hiding (Left, Right) import Game.LambdaHack.Common.Msg -import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Common.VectorXY -- TODO: if the file grows much larger, split it and move a part to Utils/ @@ -25,6 +25,7 @@ | Space | Tab | BackTab + | BackSpace | PgUp | PgDn | Left @@ -37,78 +38,25 @@ | KP !Char -- ^ a keypad key for a character (digits and operators) | Char !Char -- ^ a single printable character | Unknown !Text -- ^ an unknown key, registered to warn the user - deriving (Ord, Eq) + deriving (Read, Ord, Eq, Generic) -instance Binary Key where - put Esc = putWord8 0 - put Return = putWord8 1 - put Space = putWord8 2 - put Tab = putWord8 3 - put BackTab = putWord8 4 - put PgUp = putWord8 5 - put PgDn = putWord8 6 - put Left = putWord8 7 - put Right = putWord8 8 - put Up = putWord8 9 - put Down = putWord8 10 - put End = putWord8 11 - put Begin = putWord8 12 - put Home = putWord8 13 - put (KP c) = putWord8 14 >> put c - put (Char c) = putWord8 15 >> put c - put (Unknown s) = putWord8 16 >> put s - get = do - tag <- getWord8 - case tag of - 0 -> return Esc - 1 -> return Return - 2 -> return Space - 3 -> return Tab - 4 -> return BackTab - 5 -> return PgUp - 6 -> return PgDn - 7 -> return Left - 8 -> return Right - 9 -> return Up - 10 -> return Down - 11 -> return End - 12 -> return Begin - 13 -> return Home - 14 -> fmap KP get - 15 -> fmap Char get - 16 -> fmap Unknown get - _ -> fail "no parse (Key)" +instance Binary Key -- | Our own encoding of modifiers. Incomplete. data Modifier = NoModifier | Control - deriving (Ord, Eq) + deriving (Read, Ord, Eq, Generic) -instance Binary Modifier where - put NoModifier = putWord8 0 - put Control = putWord8 1 - get = do - tag <- getWord8 - case tag of - 0 -> return NoModifier - 1 -> return Control - _ -> fail "no parse (Modifier)" +instance Binary Modifier data KM = KM {modifier :: !Modifier, key :: !Key} - deriving (Ord, Eq) + deriving (Read, Ord, Eq, Generic) instance Show KM where show = T.unpack . showKM -instance Binary KM where - put KM {..} = do - put key - put modifier - get = do - key <- get - modifier <- get - return KM {..} +instance Binary KM -- Common and terse names for keys. showKey :: Key -> Text @@ -118,15 +66,16 @@ showKey Space = "SPACE" showKey Tab = "TAB" showKey BackTab = "SHIFT-TAB" -showKey PgUp = "PGUP" -showKey PgDn = "PGDOWN" -showKey Left = "LEFT" -showKey Right = "RIGHT" +showKey BackSpace = "BACKSPACE" showKey Up = "UP" showKey Down = "DOWN" +showKey Left = "LEFT" +showKey Right = "RIGHT" +showKey Home = "HOME" showKey End = "END" +showKey PgUp = "PGUP" +showKey PgDn = "PGDOWN" showKey Begin = "BEGIN" -showKey Home = "HOME" showKey (KP c) = "KEYPAD(" <> T.singleton c <> ")" showKey (Unknown s) = s @@ -167,29 +116,38 @@ -- | Configurable event handler for the direction keys. -- Used for directed commands such as close door. -handleDir :: X -> KM -> (Vector -> a) -> a -> a -handleDir lxsize KM{modifier=NoModifier, key} h k = - let mvs = moves lxsize - assocs = zip dirAllMoveKey $ mvs ++ mvs - in maybe k h (L.lookup key assocs) -handleDir _lxsize _ _h k = k +handleDir :: KM -> (Vector -> a) -> a -> a +handleDir KM{modifier=NoModifier, key} h k = + let assocs = zip dirAllMoveKey $ moves ++ moves + in maybe k h (lookup key assocs) +handleDir _ _ k = k -- TODO: deduplicate -- | Binding of both sets of movement keys. -moveBinding :: (VectorXY -> a) -> (VectorXY -> a) +moveBinding :: (Vector -> a) -> (Vector -> a) -> [(KM, a)] moveBinding move run = let assign f (km, dir) = (km, f dir) rNoModifier = repeat NoModifier rControl = repeat Control - in map (assign move) (zip (zipWith KM rNoModifier dirViMoveKey) movesXY) ++ - map (assign move) (zip (zipWith KM rNoModifier dirMoveKey) movesXY) ++ - map (assign run) (zip (zipWith KM rNoModifier dirViRunKey) movesXY) ++ - map (assign run) (zip (zipWith KM rNoModifier dirRunKey) movesXY) ++ - map (assign run) (zip (zipWith KM rControl dirMoveKey) movesXY) ++ - map (assign run) (zip (zipWith KM rControl dirRunKey) movesXY) ++ - map (assign run) (zip (zipWith KM rControl dirHeroKey ) movesXY) + in map (assign move) (zip (zipWith KM rNoModifier dirViMoveKey) moves) ++ + map (assign move) (zip (zipWith KM rNoModifier dirMoveKey) moves) ++ + map (assign run) (zip (zipWith KM rNoModifier dirViRunKey) moves) ++ + map (assign run) (zip (zipWith KM rNoModifier dirRunKey) moves) ++ + map (assign run) (zip (zipWith KM rControl dirMoveKey) moves) ++ + map (assign run) (zip (zipWith KM rControl dirRunKey) moves) ++ + map (assign run) (zip (zipWith KM rControl dirHeroKey ) moves) +mkKM :: String -> KM +mkKM s = let mkKey sk = + case keyTranslate sk of + Unknown _ -> + assert `failure` "unknown key" `twith` s + key -> key + in case s of + ('C':'T':'R':'L':'-':rest) -> KM {key=mkKey rest, modifier=Control} + _ -> KM {key=mkKey s, modifier=NoModifier} + -- | Translate key from a GTK string description to our internal key type. -- To be used, in particular, for the command bindings and macros -- in the config file. @@ -198,6 +156,7 @@ keyTranslate "greater" = Char '>' keyTranslate "period" = Char '.' keyTranslate "colon" = Char ':' +keyTranslate "semicolon" = Char ';' keyTranslate "comma" = Char ',' keyTranslate "question" = Char '?' keyTranslate "dollar" = Char '$' @@ -205,20 +164,24 @@ keyTranslate "KP_Multiply" = Char '*' keyTranslate "slash" = Char '/' keyTranslate "KP_Divide" = Char '/' +keyTranslate "backslash" = Char '\\' keyTranslate "underscore" = Char '_' keyTranslate "minus" = Char '-' keyTranslate "KP_Subtract" = Char '-' keyTranslate "plus" = Char '+' keyTranslate "KP_Add" = Char '+' +keyTranslate "equal" = Char '=' keyTranslate "bracketleft" = Char '[' keyTranslate "bracketright" = Char ']' keyTranslate "braceleft" = Char '{' keyTranslate "braceright" = Char '}' +keyTranslate "apostrophe" = Char '\'' keyTranslate "Escape" = Esc keyTranslate "Return" = Return keyTranslate "space" = Space keyTranslate "Tab" = Tab keyTranslate "ISO_Left_Tab" = BackTab +keyTranslate "BackSpace" = BackSpace keyTranslate "KP_Up" = Up keyTranslate "KP_Down" = Down keyTranslate "KP_Left" = Left diff --git a/Game/LambdaHack/Common/Kind.hs b/Game/LambdaHack/Common/Kind.hs --- a/Game/LambdaHack/Common/Kind.hs +++ b/Game/LambdaHack/Common/Kind.hs @@ -1,17 +1,16 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies #-} -- | General content types and operations. module Game.LambdaHack.Common.Kind - ( -- * General content types - Id, sentinelId, Speedup(..), Ops(..), COps(..), createOps, stdRuleset - -- * Arrays of content identifiers - , Array, (!), (//), listArray, array, bounds, foldlArray + ( Id, Speedup(..), Ops(..), COps(..), createOps, stdRuleset + , Tab, createTab, accessTab ) where +import Control.Exception.Assert.Sugar import qualified Data.Array.Unboxed as A import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.Ix as Ix -import qualified Data.List as L +import Data.List import qualified Data.Map.Strict as M import Data.Maybe (fromMaybe) import Data.Text (Text) @@ -29,29 +28,37 @@ import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind -import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency -- | Content identifiers for the content type @c@. newtype Id c = Id Word8 - deriving (Show, Eq, Ord, Ix.Ix, Enum) - -instance Binary (Id c) where - put (Id i) = put i - get = fmap Id get - -sentinelId :: Id c -sentinelId = Id 255 + deriving (Show, Eq, Ord, Ix.Ix, Enum, Bounded, Binary) -- | Type family for auxiliary data structures for speeding up -- content operations. data family Speedup a data instance Speedup TileKind = TileSpeedup - { isClearTab :: Id TileKind -> Bool - , isLitTab :: Id TileKind -> Bool + { isClearTab :: !Tab + , isLitTab :: !Tab + , isWalkableTab :: !Tab + , isPassableTab :: !Tab + , isDoorTab :: !Tab + , isSuspectTab :: !Tab } +newtype Tab = Tab (A.UArray (Id TileKind) Bool) + +createTab :: Ops TileKind -> (TileKind -> Bool) -> Tab +createTab Ops{ofoldrWithKey, obounds} p = + let f _ k acc = p k : acc + clearAssocs = ofoldrWithKey f [] + in Tab $ A.listArray obounds clearAssocs + +accessTab :: Tab -> Id TileKind -> Bool +{-# INLINE accessTab #-} +accessTab (Tab tab) ki = tab A.! ki + -- | Content operations for the content of type @a@. data Ops a = Ops { okind :: Id a -> a -- ^ the content element at given id @@ -70,44 +77,44 @@ -- of type @a@. createOps :: forall a. Show a => ContentDef a -> Ops a createOps ContentDef{getName, getFreq, content, validate} = - assert (Id (fromIntegral $ length content) < sentinelId) $ + assert (length content <= fromEnum (maxBound :: Id a)) $ let kindMap :: EM.EnumMap (Id a) a - !kindMap = EM.fromDistinctAscList $ L.zip [Id 0..] content + !kindMap = EM.fromDistinctAscList $ zip [Id 0..] content kindFreq :: M.Map Text (Frequency (Id a, a)) kindFreq = - let tuples = [ (group, (n, (i, k))) + let tuples = [ (cgroup, (n, (i, k))) | (i, k) <- EM.assocs kindMap - , (group, n) <- getFreq k, n > 0 ] - f m (group, nik) = M.insertWith (++) group [nik] m - lists = L.foldl' f M.empty tuples - nameFreq group = toFreq $ "opick ('" <> group <> "')" + , (cgroup, n) <- getFreq k, n > 0 ] + f m (cgroup, nik) = M.insertWith (++) cgroup [nik] m + lists = foldl' f M.empty tuples + nameFreq cgroup = toFreq $ "opick ('" <> cgroup <> "')" in M.mapWithKey nameFreq lists okind i = fromMaybe (assert `failure` "no kind" `twith` (i, kindMap)) $ EM.lookup i kindMap - correct a = not (T.null (getName a)) && L.all ((> 0) . snd) (getFreq a) + correct a = not (T.null (getName a)) && all ((> 0) . snd) (getFreq a) offenders = validate content in assert (allB correct content) $ - assert (L.null offenders `blame` "content not valid" `twith` offenders) + assert (null offenders `blame` "content not valid" `twith` offenders) -- By this point 'content' can be GCd. Ops { okind - , ouniqGroup = \group -> + , ouniqGroup = \cgroup -> let freq = fromMaybe (assert `failure` "no unique group" - `twith` (group, kindFreq)) - $ M.lookup group kindFreq + `twith` (cgroup, kindFreq)) + $ M.lookup cgroup kindFreq in case runFrequency freq of [(n, (i, _))] | n > 0 -> i - l -> assert `failure` "not unique" `twith` (l, group, kindFreq) - , opick = \group p -> - case M.lookup group kindFreq of + l -> assert `failure` "not unique" `twith` (l, cgroup, kindFreq) + , opick = \cgroup p -> + case M.lookup cgroup kindFreq of Just freq | not $ nullFreq freq -> fmap Just $ frequency $ do (i, k) <- freq breturn (p k) i {- with MonadComprehensions: - frequency [ i | (i, k) <- kindFreq M.! group, p k ] + frequency [ i | (i, k) <- kindFreq M.! cgroup, p k ] -} _ -> return Nothing - , ofoldrWithKey = \f z -> L.foldr (\(i, a) -> f i a) z + , ofoldrWithKey = \f z -> foldr (\(i, a) -> f i a) z $ EM.assocs kindMap , obounds = ( fst $ EM.findMin kindMap , fst $ EM.findMax kindMap ) @@ -135,46 +142,3 @@ instance Eq COps where (==) _ _ = True - --- | Arrays of content identifiers pointing to the content type @c@, --- where the identifiers are represented as @Word8@ --- (and so content of type @c@ can have at most 256 elements). --- The arrays are indexed by type @i@, e.g., a dungeon tile position. -newtype Array i c = Array (A.UArray i Word8) - deriving Eq - --- TODO: save/restore is still too slow, but we are already past --- the point of diminishing returns. A dramatic change would be --- low-level conversion to ByteString and serializing that. -instance (Ix.Ix i, Binary i) => Binary (Array i c) where - put (Array a) = put a - get = fmap Array get - -instance (Ix.Ix i, Show i) => Show (Array i c) where - show a = "Kind.Array with bounds " ++ show (bounds a) - --- | Content identifiers array lookup. -(!) :: Ix.Ix i => Array i c -> i -> Id c -(!) (Array a) i = Id $ a A.! i - --- | Construct a content identifiers array updated with the association list. -(//) :: Ix.Ix i => Array i c -> [(i, Id c)] -> Array i c -(//) (Array a) l = Array $ a A.// [(i, e) | (i, Id e) <- l] - --- | Create a content identifiers array from a list of elements. -listArray :: Ix.Ix i => (i, i) -> [Id c] -> Array i c -listArray bds l = Array $ A.listArray bds [e | Id e <- l] - --- | Create a content identifiers array from an association list. -array :: Ix.Ix i => (i, i) -> [(i, Id c)] -> Array i c -array bds l = Array $ A.array bds [(i, e) | (i, Id e) <- l] - --- | Content identifiers array bounds. -bounds :: Ix.Ix i => Array i c -> (i, i) -bounds (Array a) = A.bounds a - --- | Fold left strictly over an array. -foldlArray :: Ix.Ix i => (a -> Id c -> a) -> a -> Array i c -> a -foldlArray f z0 (Array a) = lgo z0 $ A.elems a - where lgo z [] = z - lgo z (x : xs) = let fzx = f z (Id x) in fzx `seq` lgo fzx xs diff --git a/Game/LambdaHack/Common/Level.hs b/Game/LambdaHack/Common/Level.hs --- a/Game/LambdaHack/Common/Level.hs +++ b/Game/LambdaHack/Common/Level.hs @@ -12,14 +12,16 @@ -- * Level update , updatePrio, updateSmell, updateFloor, updateTile -- * Level query - , at, atI, accessible, accessibleDir, isSecretPos, hideTile + , at, atI, checkAccess, checkDoorAccess, accessible, accessibleDir + , isSecretPos, hideTile , findPos, findPosTry, mapLevelActors_, mapDungeonActors_ ) where +import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.Bits as Bits import qualified Data.EnumMap.Strict as EM -import qualified Data.List as L +import Data.Maybe import Data.Text (Text) import GHC.Generics (Generic) @@ -27,7 +29,7 @@ import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.PointXY +import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Tile import qualified Game.LambdaHack.Common.Tile as Tile @@ -35,15 +37,14 @@ import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind -import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency -- | The complete dungeon is a map from level names to levels. type Dungeon = EM.EnumMap LevelId Level -- | Levels in the current branch, @k@ levels shallower than the current. -ascendInBranch :: Dungeon -> LevelId -> Int -> [LevelId] -ascendInBranch dungeon lid k = +ascendInBranch :: Dungeon -> Int -> LevelId -> [LevelId] +ascendInBranch dungeon k lid = -- Currently there is just one branch, so the computation is simple. let (minD, maxD) = case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of @@ -69,7 +70,7 @@ type ItemFloor = EM.EnumMap Point ItemBag -- | Tile kinds on the map. -type TileMap = Kind.Array Point TileKind +type TileMap = PointArray.Array (Kind.Id TileKind) -- | Current smell on map tiles. type SmellMap = EM.EnumMap Point SmellTime @@ -86,15 +87,17 @@ , lsmell :: !SmellMap -- ^ remembered smells on the level , ldesc :: !Text -- ^ level description , lstair :: !([Point], [Point]) - -- ^ destinations of (up, down) stairs + -- ^ destinations of (up, down) stairs , lseen :: !Int -- ^ currently remembered clear tiles - , lclear :: !Int -- ^ total number of initially clear tiles + , lclear :: !Int -- ^ total number of initially clear tiles; + -- set to 1 on clients when fully explored , ltime :: !Time -- ^ date of the last activity on the level , litemNum :: !Int -- ^ number of initial items, 0 for clients , litemFreq :: !(Frequency Text) -- ^ frequency of initial items, -- [] for clients , lsecret :: !Int -- ^ secret tile seed , lhidden :: !Int -- ^ secret tile density + , lescape :: !Bool -- ^ has an Effect.Escape tile } deriving (Show, Eq) @@ -121,23 +124,40 @@ -- | Query for tile kinds on the map. at :: Level -> Point -> Kind.Id TileKind -at Level{ltile} p = ltile Kind.! p +at Level{ltile} p = ltile PointArray.! p -- | Query for items on the ground. atI :: Level -> Point -> ItemBag atI Level{lfloor} p = EM.findWithDefault EM.empty p lfloor +checkAccess :: Kind.COps -> Level -> Maybe (Point -> Point -> Bool) +checkAccess Kind.COps{corule} _ = + case raccessible $ Kind.stdRuleset corule of + Nothing -> Nothing + Just ch -> Just $ \spos tpos -> ch spos tpos + +checkDoorAccess :: Kind.COps -> Level -> Maybe (Point -> Point -> Bool) +checkDoorAccess Kind.COps{corule, cotile} lvl = + case raccessibleDoor $ Kind.stdRuleset corule of + Nothing -> Nothing + Just chDoor -> + Just $ \spos tpos -> + let st = lvl `at` spos + tt = lvl `at` tpos + in not (Tile.isDoor cotile st || Tile.isDoor cotile tt) + || chDoor spos tpos + -- | Check whether one position is accessible from another, -- using the formula from the standard ruleset. -- Precondition: the two positions are next to each other. accessible :: Kind.COps -> Level -> Point -> Point -> Bool -accessible Kind.COps{cotile=Kind.Ops{okind=okind}, corule} - lvl@Level{lxsize} spos tpos = - assert (chessDist lxsize spos tpos == 1) $ - let check = raccessible $ Kind.stdRuleset corule - src = okind $ lvl `at` spos - tgt = okind $ lvl `at` tpos - in check lxsize spos src tpos tgt +accessible cops@Kind.COps{cotile} lvl = + let checkWalkability = + Just $ \_ tpos -> Tile.isWalkable cotile $ lvl `at` tpos + conditions = catMaybes [ checkWalkability + , checkAccess cops lvl + , checkDoorAccess cops lvl ] + in \spos tpos -> all (\f -> f spos tpos) conditions -- | Check whether actors can move from a position along a unit vector, -- using the formula from the standard ruleset. @@ -158,11 +178,14 @@ -- | Find a random position on the map satisfying a predicate. findPos :: TileMap -> (Point -> Kind.Id TileKind -> Bool) -> Rnd Point findPos ltile p = - let search = do - pos <- randomR $ Kind.bounds ltile - let tile = ltile Kind.! pos + let (x, y) = PointArray.sizeA ltile + search = do + px <- randomR (0, x - 1) + py <- randomR (0, y - 1) + let pos = Point{..} + tile = ltile PointArray.! pos if p pos tile - then return pos + then return $! pos else search in search @@ -179,12 +202,15 @@ -> Rnd Point findPosTry _ ltile m [] = findPos ltile m findPosTry numTries ltile m l@(_ : tl) = assert (numTries > 0) $ - let search 0 = findPosTry numTries ltile m tl + let (x, y) = PointArray.sizeA ltile + search 0 = findPosTry numTries ltile m tl search k = do - pos <- randomR $ Kind.bounds ltile - let tile = ltile Kind.! pos - if m pos tile && L.all (\p -> p pos tile) l - then return pos + px <- randomR (0, x - 1) + py <- randomR (0, y - 1) + let pos = Point{..} + tile = ltile PointArray.! pos + if m pos tile && all (\p -> p pos tile) l + then return $! pos else search (k - 1) in search numTries @@ -216,6 +242,7 @@ put litemFreq put lsecret put lhidden + put lescape get = do ldepth <- get lprio <- get @@ -233,4 +260,5 @@ litemFreq <- get lsecret <- get lhidden <- get - return Level{..} + lescape <- get + return $! Level{..} diff --git a/Game/LambdaHack/Common/Misc.hs b/Game/LambdaHack/Common/Misc.hs --- a/Game/LambdaHack/Common/Misc.hs +++ b/Game/LambdaHack/Common/Misc.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Hacks that haven't found their home yet. module Game.LambdaHack.Common.Misc - ( normalLevelBound, maxLevelDim, divUp, Freqs, breturn + ( normalLevelBound, divUp, Freqs, breturn , FactionId, LevelId ) where @@ -19,15 +19,11 @@ -- | Level bounds. TODO: query terminal size instead and scroll view. normalLevelBound :: (Int, Int) -normalLevelBound = (79, 21) - --- | Maximal supported level X and Y dimension (32768). Not checked anywhere. --- The value is chosen to support architectures with 32-bit ints. -maxLevelDim :: Int -maxLevelDim = 2 ^ (15 :: Int) +normalLevelBound = (79, 20) +infixl 7 `divUp` -- | Integer division, rounding up. -divUp :: Int -> Int -> Int +divUp :: Integral a => a -> a -> a divUp n k = (n + k - 1) `div` k -- | For each group that the kind belongs to, denoted by a @Text@ name diff --git a/Game/LambdaHack/Common/Msg.hs b/Game/LambdaHack/Common/Msg.hs --- a/Game/LambdaHack/Common/Msg.hs +++ b/Game/LambdaHack/Common/Msg.hs @@ -2,35 +2,39 @@ -- | Game messages displayed on top of the screen for the player to read. module Game.LambdaHack.Common.Msg ( makePhrase, makeSentence - , Msg, (<>), (<+>), showT, moreMsg, yesnoMsg, truncateMsg + , Msg, (<>), (<+>), tshow, toWidth, moreMsg, yesnoMsg, truncateMsg , Report, emptyReport, nullReport, singletonReport, addMsg , splitReport, renderReport, findInReport , History, emptyHistory, singletonHistory, mergeHistory , addReport, renderHistory, takeHistory - , Overlay, stringByLocation - , Slideshow(runSlideshow), splitOverlay, toSlideshow) + , Overlay(overlay), emptyOverlay, truncateToOverlay, toOverlay + , Slideshow(slideshow), splitOverlay, toSlideshow) where import Data.Binary import qualified Data.ByteString.Char8 as BS -import Data.Char -import qualified Data.EnumMap.Strict as EM import Data.List -import Data.Monoid hiding ((<>)) +import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import NLP.Miniutter.English ((<+>), (<>)) import qualified NLP.Miniutter.English as MU import qualified Text.Show.Pretty as Show.Pretty import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.PointXY +import Game.LambdaHack.Common.Point +infixr 6 <+> -- TODO: not needed when we require a very new minimorph +(<+>) :: Text -> Text -> Text +(<+>) = (MU.<+>) + -- Pretty print and pack the result of @show@. -showT :: Show a => a -> Text -showT x = T.pack $ Show.Pretty.ppShow x +tshow :: Show a => a -> Text +tshow x = T.pack $ Show.Pretty.ppShow x +toWidth :: Int -> Text -> Text +toWidth n x = T.take n (T.justifyLeft n ' ' x) + -- | Re-exported English phrase creation functions, applied to default -- irregular word sets. makePhrase, makeSentence :: [MU.Part] -> Text @@ -56,7 +60,7 @@ let xs = case T.lines xsRaw of [] -> xsRaw [line] -> line - line : _ -> line <> T.replicate (w + 1) " " + line : _ -> T.justifyLeft (w + 1) ' ' line len = T.length xs in case compare w len of LT -> T.snoc (T.take (w - 1) xs) '$' @@ -67,11 +71,7 @@ -- | The type of a set of messages to show at the screen at once. newtype Report = Report [(BS.ByteString, Int)] - deriving (Show) - -instance Binary Report where - put (Report x) = put x - get = fmap Report get + deriving (Show, Binary) -- | Empty set of messages. emptyReport :: Report @@ -96,11 +96,12 @@ -- | Split a messages into chunks that fit in one line. -- We assume the width of the messages line is the same as of level map. -splitReport :: Report -> [Text] -splitReport r = - let w = fst normalLevelBound + 1 - in splitText w $ renderReport r +splitReport :: X -> Report -> Overlay +splitReport w r = Overlay $ splitReportList w r +splitReportList :: X -> Report -> [Text] +splitReportList w r = splitText w $ renderReport r + -- | Render a report as a (possibly very long) string. renderReport :: Report -> Text renderReport (Report []) = T.empty @@ -109,7 +110,7 @@ renderRepetition :: (BS.ByteString, Int) -> Text renderRepetition (s, 1) = decodeUtf8 s -renderRepetition (s, n) = decodeUtf8 s <> " showT n <> ">" +renderRepetition (s, n) = decodeUtf8 s <> " tshow n <> ">" findInReport :: (BS.ByteString -> Bool) -> Report -> Maybe BS.ByteString findInReport f (Report xns) = find f $ map fst xns @@ -118,27 +119,22 @@ -- other than whitespace or punctuation. Space characters are removed -- from the start, but never from the end of lines. Newlines are respected. splitText :: X -> Text -> [Text] -splitText w xs = concatMap (splitText' w . T.dropWhile isSpace) $ T.lines xs +splitText w xs = concatMap (splitText' w . T.stripStart) $ T.lines xs splitText' :: X -> Text -> [Text] splitText' w xs - | w <= 0 = [xs] -- border case, we cannot make progress | w >= T.length xs = [xs] -- no problem, everything fits | otherwise = let (pre, post) = T.splitAt w xs (ppre, ppost) = T.break (== ' ') $ T.reverse pre - testPost = T.dropWhile isSpace ppost + testPost = T.stripEnd ppost in if T.null testPost then pre : splitText w post else T.reverse ppost : splitText w (T.reverse ppre <> post) -- | The history of reports. newtype History = History [Report] - deriving Show - -instance Binary History where - put (History x) = put x - get = fmap History get + deriving (Show, Binary) -- | Empty history of reports. emptyHistory :: History @@ -156,7 +152,9 @@ -- | Render history as many lines of text, wrapping if necessary. renderHistory :: History -> Overlay -renderHistory (History h) = concatMap splitReport h +renderHistory (History h) = + let w = fst normalLevelBound + 1 + in Overlay $ concatMap (splitReportList w) h -- | Add a report to history, handling repetitions. addReport :: Report -> History -> History @@ -176,48 +174,47 @@ -- | A series of screen lines that may or may not fit the width nor height -- of the screen. An overlay may be transformed by adding the first line -- and/or by splitting into a slideshow of smaller overlays. -type Overlay = [Text] +newtype Overlay = Overlay {overlay :: [Text]} + deriving (Show, Eq, Binary) --- | Returns a function that looks up the characters in the --- string by position. Takes the width and height of the display plus --- the string. Returns also the message to print at the top and bottom. -stringByLocation :: X -> Y -> Overlay - -> (Text, PointXY -> Maybe Char, Maybe Text) -stringByLocation _ _ [] = (T.empty, const Nothing, Nothing) -stringByLocation lxsize lysize (msgTop : ls) = - let (over, bottom) = splitAt lysize $ map (truncateMsg lxsize) ls - m = EM.fromDistinctAscList - $ zip [0..] - (map (EM.fromDistinctAscList . zip [0..] . T.unpack) over) - msgBottom = case bottom of - [] -> Nothing - [s] -> Just s - _ -> Just "--a portion of the text trimmed--" - in (truncateMsg lxsize msgTop, - \ (PointXY (x, y)) -> EM.lookup y m >>= \ n -> EM.lookup x n, - msgBottom) +emptyOverlay :: Overlay +emptyOverlay = Overlay [] +truncateToOverlay :: X -> Text -> Overlay +truncateToOverlay lxsize msg = Overlay [truncateMsg lxsize msg] + +toOverlay :: [Text] -> Overlay +toOverlay = Overlay + -- | Split an overlay into a slideshow in which each overlay, -- prefixed by @msg@ and postfixed by @moreMsg@ except for the last one, --- fits on the screen wrt height (but lines may still be too wide). -splitOverlay :: Y -> Overlay -> Overlay -> Slideshow -splitOverlay lysize msg ls = +-- fits on the screen wrt height (but lines may be too wide). +splitOverlay :: Bool -> Y -> Overlay -> Overlay -> Slideshow +splitOverlay onBlank yspace (Overlay msg) (Overlay ls) = let over = msg ++ ls - in if length over <= lysize + 2 - then Slideshow [over] -- all fits on one screen - else let (pre, post) = splitAt (lysize + 1) over - Slideshow slides = splitOverlay lysize msg post - in Slideshow $ (pre ++ [moreMsg]) : slides + in if length over <= yspace + then Slideshow (onBlank, [Overlay over]) -- all fits on one screen + else let (pre, post) = splitAt (yspace - 1) over + Slideshow (_, slides) = + splitOverlay onBlank yspace (Overlay msg) (Overlay post) + in Slideshow $ (onBlank, (Overlay $ pre ++ [moreMsg]) : slides) -- | A few overlays, displayed one by one upon keypress. -- When displayed, they are trimmed, not wrapped -- and any lines below the lower screen edge are not visible. -newtype Slideshow = Slideshow {runSlideshow :: [Overlay]} - deriving (Monoid, Show) +-- If the boolean flag is set, the overlay is displayed over a blank screen, +-- including the bottom lines. +newtype Slideshow = Slideshow {slideshow :: (Bool, [Overlay])} + deriving Show --- | Declare the list of overlays to be fit for display on the screen. +instance Monoid Slideshow where + mempty = Slideshow (False, []) + mappend (Slideshow (b1, l1)) (Slideshow (b2, l2)) = + Slideshow (b1 || b2, l1 ++ l2) + +-- | Declare the list of raw overlays to be fit for display on the screen. -- In particular, current @Report@ is eiter empty or unimportant -- or contained in the overlays and if any vertical or horizontal -- trimming of the overlays happens, this is intended. -toSlideshow :: [Overlay] -> Slideshow -toSlideshow = Slideshow +toSlideshow :: Bool -> [[Text]] -> Slideshow +toSlideshow onBlank l = Slideshow (onBlank, map Overlay l) diff --git a/Game/LambdaHack/Common/Perception.hs b/Game/LambdaHack/Common/Perception.hs --- a/Game/LambdaHack/Common/Perception.hs +++ b/Game/LambdaHack/Common/Perception.hs @@ -17,9 +17,9 @@ -- the tile, so the player can flee or block. Invisible actors in open -- space can be hit. module Game.LambdaHack.Common.Perception - ( Perception(..), PerceptionVisible(..), PerActor + ( Perception(Perception), PerceptionVisible(PerceptionVisible) , totalVisible, smellVisible - , actorSeesPos, nullPer, addPer, diffPer, smellFromActors + , nullPer, addPer, diffPer , FactionPers, Pers ) where @@ -28,30 +28,20 @@ import qualified Data.EnumSet as ES import GHC.Generics (Generic) -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction -import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.State -import Game.LambdaHack.Content.ActorKind --- TOOD: if really needed, optimize by representing as a set of intervals. newtype PerceptionVisible = PerceptionVisible - { pvisible :: ES.EnumSet Point} + {pvisible :: ES.EnumSet Point} deriving (Show, Eq, Binary) -type PerActor = EM.EnumMap ActorId PerceptionVisible - +-- TOOD: if really needed, optimize by representing as a set of intervals +-- or a set of bitmaps, like the internal representation of IntSet. -- | The type representing the perception of a faction on a level. --- The total visibility holds the sum of FOVs of all actors --- of a given faction on the level and serves only as a speedup. --- The fields are not strict because often not all are used. data Perception = Perception - { perActor :: !PerActor -- ^ visible points for each actor - , ptotal :: !PerceptionVisible -- ^ sum over all actors - , psmell :: !PerceptionVisible -- ^ sum over actors that can smell + { ptotal :: !PerceptionVisible -- ^ sum over all actors + , psmell :: !PerceptionVisible -- ^ sum over actors that can smell } deriving (Show, Eq, Generic) @@ -72,52 +62,23 @@ smellVisible :: Perception -> ES.EnumSet Point smellVisible = pvisible . psmell --- | Whether an actor can see a position. -actorSeesPos :: Perception -> ActorId -> Point -> Bool -actorSeesPos per aid pos = - let isIn = (pos `ES.member`) . pvisible - -- Blind and non-smelling actors don't see their own pos, hence False. - in maybe False isIn $ EM.lookup aid $ perActor per - nullPer :: Perception -> Bool -nullPer per = ES.null (totalVisible per) +nullPer per = ES.null (totalVisible per) && ES.null (smellVisible per) addPer :: Perception -> Perception -> Perception addPer per1 per2 = - let f :: (PerceptionVisible -> PerceptionVisible -> PerceptionVisible) - f pv1 pv2 = PerceptionVisible $ pvisible pv1 `ES.union` pvisible pv2 - in Perception - { perActor = EM.unionWith f (perActor per1) (perActor per2) - , ptotal = PerceptionVisible - $ totalVisible per1 `ES.union` totalVisible per2 - , psmell = PerceptionVisible - $ smellVisible per1 `ES.union` smellVisible per2 - } + Perception + { ptotal = PerceptionVisible + $ totalVisible per1 `ES.union` totalVisible per2 + , psmell = PerceptionVisible + $ smellVisible per1 `ES.union` smellVisible per2 + } diffPer :: Perception -> Perception -> Perception diffPer per1 per2 = - let f :: (PerceptionVisible -> PerceptionVisible -> Maybe PerceptionVisible) - f pv1 pv2 = - let diff = pvisible pv1 ES.\\ pvisible pv2 - in if ES.null diff then Nothing else Just $ PerceptionVisible diff - in Perception - { perActor = EM.differenceWith f (perActor per1) (perActor per2) - , ptotal = PerceptionVisible - $ totalVisible per1 ES.\\ totalVisible per2 - , psmell = PerceptionVisible - $ smellVisible per1 ES.\\ smellVisible per2 - } - -smellFromActors :: Kind.COps -> State -> PerActor -> PerceptionVisible -smellFromActors Kind.COps{coactor=Kind.Ops{okind}} s perActor = - let actorCanSmell aid = - -- If actor is just created, it can already be in Perception - -- sent to the client, but not in the client's state. - -- We assume the actor's nose doesn't work yet on first turn. - -- TODO: assume so on the server, too, or overhaul smelling again. - not (EM.notMember aid $ sactorD s) - && let b = getActorBody aid s - in asmell $ okind $ bkind b - visSmell = filter (actorCanSmell . fst) $ EM.assocs perActor - setSmell = map (pvisible . snd) visSmell - in PerceptionVisible $ ES.unions setSmell + Perception + { ptotal = PerceptionVisible + $ totalVisible per1 ES.\\ totalVisible per2 + , psmell = PerceptionVisible + $ smellVisible per1 ES.\\ smellVisible per2 + } diff --git a/Game/LambdaHack/Common/Point.hs b/Game/LambdaHack/Common/Point.hs --- a/Game/LambdaHack/Common/Point.hs +++ b/Game/LambdaHack/Common/Point.hs @@ -1,113 +1,136 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Basic operations on 2D points represented as linear offsets. module Game.LambdaHack.Common.Point - ( Point, toPoint, showPoint - , origin, chessDist, adjacent, vicinity, vicinityCardinal - , inside, displacementXYZ, bla + ( X, Y, Point(..), maxLevelDimExponent + , chessDist, euclidDistSq, adjacent, inside, bla, fromTo ) where +import Control.Exception.Assert.Sugar import Data.Binary -import qualified Data.Ix as Ix -import qualified Data.List as L -import Data.Text (Text) -import qualified System.Random as R +import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) +import Data.Int (Int32) -import Game.LambdaHack.Common.Msg -import Game.LambdaHack.Common.PointXY -import Game.LambdaHack.Common.VectorXY -import Control.Exception.Assert.Sugar +-- | Spacial dimension for points and vectors. +type X = Int --- | The type of positions on the 2D level map, heavily optimized. --- --- We represent the (level map on the) screen as a linear framebuffer, --- where @Point@ is an @Int@ offset counted from the first cell. --- We do bounds check for the X size whenever we convert --- between representations and each subsequent array access --- performs another check, effectively for Y size. --- After dungeon is generated (using @PointXY@, not @Point@), --- and converted to the @Point@ representation, points are used --- mainly as keys and not constructed often, so the performance will improve --- due to smaller save files, the use of @EnumMap@ and cheaper array indexing, --- including cheaper bounds checks. -newtype Point = Point Int - deriving (Eq, Ord, Ix.Ix, Enum, R.Random) +-- | Spacial dimension for points and vectors. +type Y = Int -instance Binary Point where - put (Point n) = put n - get = fmap Point get +-- | 2D points in cartesian representation. Coordinates grow to the right +-- and down, so that the (0, 0) point is in the top-left corner of the screen. +-- Coordinates are never negative. +data Point = Point + { px :: !X + , py :: !Y + } + deriving (Eq, Ord) --- For debugging. instance Show Point where - show (Point n) = show n + show (Point x y) = show (x, y) --- | Print a point as a tuple of cartesian coordinates. -showPoint :: X -> Point -> Text -showPoint lxsize = showT . fromPoint lxsize +instance Binary Point where + put = put . (fromIntegral :: Int -> Int32) . fromEnum + get = fmap (toEnum . (fromIntegral :: Int32 -> Int)) get --- | Conversion from cartesian coordinates to @Point@. -toPoint :: X -> PointXY -> Point -toPoint lxsize (PointXY (x, y)) = - assert (lxsize > x && x >= 0 && y >= 0 `blame` "invalid point coordinates" - `twith` (lxsize, x, y)) - $ Point $ x + y * lxsize +-- This conversion cannot be used for PointArray indexing, +-- because it is not contiguous --- we don't know the horizontal +-- width of the levels nor of the screen. +-- The conversion is implemented mainly for @EnumMap@ and @EnumSet@. +instance Enum Point where + fromEnum = fromEnumPoint + toEnum = toEnumPoint --- | Conversion from @Point@ to cartesian coordinates. -fromPoint :: X -> Point -> PointXY -fromPoint lxsize (Point p) = - assert (p >= 0 `blame` "negative point value" `twith` (lxsize, p)) - $ PointXY (p `rem` lxsize, p `quot` lxsize) +-- | The maximum number of bits for level X and Y dimension (16). +-- The value is chosen to support architectures with 32-bit Ints. +maxLevelDimExponent :: Int +{-# INLINE maxLevelDimExponent #-} +maxLevelDimExponent = 16 --- | The top-left corner position of the level. -origin :: Point -origin = Point 0 +-- | Maximal supported level X and Y dimension. Not checked anywhere. +-- The value is chosen to support architectures with 32-bit Ints. +maxLevelDim :: Int +{-# INLINE maxLevelDim #-} +maxLevelDim = 2 ^ maxLevelDimExponent - 1 +fromEnumPoint :: Point -> Int +{-# INLINE fromEnumPoint #-} +fromEnumPoint (Point x y) = + assert (x >= 0 && y >= 0 `blame` "invalid point coordinates" + `twith` (x, y)) + $ x + unsafeShiftL y maxLevelDimExponent + +toEnumPoint :: Int -> Point +{-# INLINE toEnumPoint #-} +toEnumPoint n = + Point (n .&. maxLevelDim) (unsafeShiftR n maxLevelDimExponent) + -- | The distance between two points in the chessboard metric. -chessDist :: X -> Point -> Point -> Int -chessDist lxsize pos0 pos1 - | PointXY (x0, y0) <- fromPoint lxsize pos0 - , PointXY (x1, y1) <- fromPoint lxsize pos1 = - chessDistXY $ VectorXY (x1 - x0, y1 - y0) +chessDist :: Point -> Point -> Int +{-# INLINE chessDist #-} +chessDist (Point x0 y0) (Point x1 y1) = max (abs (x1 - x0)) (abs (y1 - y0)) +-- | Squared euclidean distance between two points. +euclidDistSq :: Point -> Point -> Int +{-# INLINE euclidDistSq #-} +euclidDistSq (Point x0 y0) (Point x1 y1) = + let square n = n ^ (2 :: Int) + in square (x1 - x0) + square (y1 - y0) + -- | Checks whether two points are adjacent on the map -- (horizontally, vertically or diagonally). -adjacent :: X -> Point -> Point -> Bool -adjacent lxsize s t = chessDist lxsize s t == 1 - --- | Returns the 8, or less, surrounding positions of a given position. -vicinity :: X -> Y -> Point -> [Point] -vicinity lxsize lysize p = - map (toPoint lxsize) $ - vicinityXY (0, 0, lxsize - 1, lysize - 1) $ - fromPoint lxsize p - --- | Returns the 4, or less, surrounding positions in cardinal directions --- from a given position. -vicinityCardinal :: X -> Y -> Point -> [Point] -vicinityCardinal lxsize lysize p = - map (toPoint lxsize) $ - vicinityCardinalXY (0, 0, lxsize - 1, lysize - 1) $ - fromPoint lxsize p +adjacent :: Point -> Point -> Bool +{-# INLINE adjacent #-} +adjacent s t = chessDist s t == 1 -- | Checks that a point belongs to an area. -inside :: X -> Point -> (X, Y, X, Y) -> Bool -inside lxsize p = insideXY $ fromPoint lxsize p - --- | Calculate the displacement vector from a position to another. -displacementXYZ :: X -> Point -> Point -> VectorXY -displacementXYZ lxsize pos0 pos1 - | PointXY (x0, y0) <- fromPoint lxsize pos0 - , PointXY (x1, y1) <- fromPoint lxsize pos1 = - VectorXY (x1 - x0, y1 - y0) +inside :: Point -> (X, Y, X, Y) -> Bool +{-# INLINE inside #-} +inside (Point x y) (x0, y0, x1, y1) = x1 >= x && x >= x0 && y1 >= y && y >= y0 -- | Bresenham's line algorithm generalized to arbitrary starting @eps@ -- (@eps@ value of 0 gives the standard BLA). -- Skips the source point and goes through the second point -- to the edge of the level. GIves @Nothing@ if the points are equal. +-- The target is given as @Point@ to permit aiming out of the level, +-- e.g., to get uniform distributions of directions for explosions +-- close to the edge of the level. bla :: X -> Y -> Int -> Point -> Point -> Maybe [Point] -bla _ _ _ source target | source == target = Nothing -bla lxsize lysize eps source target = Just $ - let s = fromPoint lxsize source - e = fromPoint lxsize target - inBounds p@(PointXY (x, y)) = - lxsize > x && x >= 0 && lysize > y && y >= 0 && p /= s - in L.map (toPoint lxsize) $ L.takeWhile inBounds $ L.tail $ blaXY eps s e +bla lxsize lysize eps source target = + if source == target then Nothing + else Just $ + let inBounds p@(Point x y) = + lxsize > x && x >= 0 && lysize > y && y >= 0 && p /= source + in takeWhile inBounds $ tail $ blaXY eps source target + +-- | Bresenham's line algorithm generalized to arbitrary starting @eps@ +-- (@eps@ value of 0 gives the standard BLA). Includes the source point +-- and goes through the target point to infinity. +blaXY :: Int -> Point -> Point -> [Point] +blaXY eps (Point x0 y0) (Point x1 y1) = + let (dx, dy) = (x1 - x0, y1 - y0) + xyStep b (x, y) = (x + signum dx, y + signum dy * b) + yxStep b (x, y) = (x + signum dx * b, y + signum dy) + (p, q, step) | abs dx > abs dy = (abs dy, abs dx, xyStep) + | otherwise = (abs dx, abs dy, yxStep) + bw = balancedWord p q (eps `mod` max 1 q) + walk w xy = xy : walk (tail w) (step (head w) xy) + in map (uncurry Point) $ walk bw (x0, y0) + +-- | See . +balancedWord :: Int -> Int -> Int -> [Int] +balancedWord p q eps | eps + p < q = 0 : balancedWord p q (eps + p) +balancedWord p q eps = 1 : balancedWord p q (eps + p - q) + +-- | A list of all points on a straight vertical or straight horizontal line +-- between two points. Fails if no such line exists. +fromTo :: Point -> Point -> [Point] +fromTo (Point x0 y0) (Point x1 y1) = + let fromTo1 :: Int -> Int -> [Int] + fromTo1 z0 z1 + | z0 <= z1 = [z0..z1] + | otherwise = [z0,z0-1..z1] + result + | x0 == x1 = map (\ y -> Point x0 y) (fromTo1 y0 y1) + | y0 == y1 = map (\ x -> Point x y0) (fromTo1 x0 x1) + | otherwise = assert `failure` "diagonal fromTo" + `twith` ((x0, y0), (x1, y1)) + in result diff --git a/Game/LambdaHack/Common/PointArray.hs b/Game/LambdaHack/Common/PointArray.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Common/PointArray.hs @@ -0,0 +1,133 @@ +-- | Arrays, based on Data.Vector.Unboxed, indexed by @Point@. +module Game.LambdaHack.Common.PointArray + ( Array + , (!), (//), replicateA, replicateMA, generateMA, sizeA + , foldlA, ifoldlA, minIndexA, minLastIndexA, maxIndexA, maxLastIndexA + ) where + +import Control.Arrow ((***)) +import Control.Monad +import Data.Binary +import Data.Vector.Binary () +import qualified Data.Vector.Fusion.Stream as Stream +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U + +import Game.LambdaHack.Common.Point + +-- TODO: for now, until there's support for GeneralizedNewtypeDeriving +-- for Unboxed, there's a lot of @Word8@ in place of @c@ here +-- and a contraint @Enum c@ instead of @Unbox c@. + +-- TODO: perhaps make them an instance of Data.Vector.Generic? +-- | Arrays indexed by @Point@. +data Array c = Array + { axsize :: X + , aysize :: Y + , avector :: U.Vector Word8 + } + deriving Eq + +instance Show (Array c) where + show a = "PointArray.Array with size " ++ show (sizeA a) + +cnv :: (Enum a, Enum b) => a -> b +cnv = toEnum . fromEnum + +pindex :: X -> Point -> Int +pindex xsize (Point x y) = x + y * xsize + +punindex :: X -> Int -> Point +punindex xsize n = let (y, x) = n `quotRem` xsize + in Point x y + +-- Note: there's no point specializing this to @Point@ arguments, +-- since the extra few additions in @fromPoint@ may be less expensive than +-- memory or register allocations needed for the extra @Int@ in @Point@. +-- | Array lookup. +(!) :: Enum c => Array c -> Point -> c +{-# INLINE (!) #-} +(!) Array{..} p = cnv $ avector U.! pindex axsize p + +-- | Construct an array updated with the association list. +(//) :: Enum c => Array c -> [(Point, c)] -> Array c +(//) Array{..} l = let v = avector U.// map (pindex axsize *** cnv) l + in Array{avector = v, ..} + +-- | Create an array from a replicated element. +replicateA :: Enum c => X -> Y -> c -> Array c +replicateA axsize aysize c = + Array{avector = U.replicate (axsize * aysize) $ cnv c, ..} + +-- | Create an array from a replicated monadic action. +replicateMA :: Enum c => Monad m => X -> Y -> m c -> m (Array c) +replicateMA axsize aysize m = do + v <- U.replicateM (axsize * aysize) $ liftM cnv m + return $! Array{avector = v, ..} + +-- | Create an array from a monadic function. +generateMA :: Enum c => Monad m => X -> Y -> (Point -> m c) -> m (Array c) +generateMA axsize aysize fm = do + let gm n = liftM cnv $ fm $ punindex axsize n + v <- U.generateM (axsize * aysize) gm + return $! Array{avector = v, ..} + +-- | Content identifiers array size. +sizeA :: Array c -> (X, Y) +sizeA Array{..} = (axsize, aysize) + +-- | Fold left strictly over an array. +foldlA :: Enum c => (a -> c -> a) -> a -> Array c -> a +foldlA f z0 Array{..} = + U.foldl' (\a c -> f a (cnv c)) z0 avector + +-- | Fold left strictly over an array +-- (function applied to each element and its index). +ifoldlA :: Enum c => (a -> Point -> c -> a) -> a -> Array c -> a +ifoldlA f z0 Array{..} = + U.ifoldl' (\a n c -> f a (punindex axsize n) (cnv c)) z0 avector + +-- | Yield the point coordinates of a minimum element of the array. +-- The array may not be empty. +minIndexA :: Enum c => Array c -> Point +{-# INLINE minIndexA #-} +minIndexA Array{..} = punindex axsize $ U.minIndex avector + +-- | Yield the point coordinates of the last minimum element of the array. +-- The array may not be empty. +minLastIndexA :: Enum c => Array c -> Point +{-# INLINE minLastIndexA #-} +minLastIndexA Array{..} = + punindex axsize + $ fst . Stream.foldl1' imin . Stream.indexed . G.stream + $ avector + where + imin (i, x) (j, y) = i `seq` j `seq` if x >= y then (j, y) else (i, x) + +-- | Yield the point coordinates of the first maximum element of the array. +-- The array may not be empty. +maxIndexA :: Enum c => Array c -> Point +{-# INLINE maxIndexA #-} +maxIndexA Array{..} = punindex axsize $ U.maxIndex avector + +-- | Yield the point coordinates of the last maximum element of the array. +-- The array may not be empty. +maxLastIndexA :: Enum c => Array c -> Point +{-# INLINE maxLastIndexA #-} +maxLastIndexA Array{..} = + punindex axsize + $ fst . Stream.foldl1' imax . Stream.indexed . G.stream + $ avector + where + imax (i, x) (j, y) = i `seq` j `seq` if x <= y then (j, y) else (i, x) + +instance Binary (Array c) where + put Array{..} = do + put axsize + put aysize + put avector + get = do + axsize <- get + aysize <- get + avector <- get + return $! Array{..} diff --git a/Game/LambdaHack/Common/PointXY.hs b/Game/LambdaHack/Common/PointXY.hs deleted file mode 100644 --- a/Game/LambdaHack/Common/PointXY.hs +++ /dev/null @@ -1,79 +0,0 @@ --- | Basic cartesian geometry operations on 2D points. -module Game.LambdaHack.Common.PointXY - ( X, Y, PointXY(..), fromTo, sortPointXY, blaXY, insideXY - ) where - -import qualified Data.List as L - -import Game.LambdaHack.Common.Misc -import Control.Exception.Assert.Sugar - --- | Spacial dimension for points and vectors. -type X = Int - --- | Spacial dimension for points and vectors. -type Y = Int - --- | 2D points in cartesian representation. -newtype PointXY = PointXY (X, Y) - deriving (Eq, Ord) - -instance Show PointXY where - show (PointXY (x, y)) = show (x, y) - --- TODO: perhaps use this instead of Point, but then @shift@ is not longer --- so cheap, and we need, e.g., an extra addition per FOV point and per --- AI speculative move. Additions are cheap though and code would be --- shorter thanks to removing the lxsize argument in many places. --- More serious is one addition and one multiplication per EnumMap lookup, --- though in the computation-intensive cases of FOV and AI, the extra --- operations were already there, performed before lookup. --- TODO: rem and quot by 2^w can probably be optimised -instance Enum PointXY where - toEnum p = PointXY (p `rem` maxLevelDim, p `quot` maxLevelDim) - fromEnum (PointXY (x, y)) = x + y * maxLevelDim - --- | A list of all points on a straight vertical or straight horizontal line --- between two points. Fails if no such line exists. -fromTo :: PointXY -> PointXY -> [PointXY] -fromTo (PointXY (x0, y0)) (PointXY (x1, y1)) = - let result - | x0 == x1 = L.map (\ y -> PointXY (x0, y)) (fromTo1 y0 y1) - | y0 == y1 = L.map (\ x -> PointXY (x, y0)) (fromTo1 x0 x1) - | otherwise = assert `failure` "diagononal fromTo" - `twith` ((x0, y0), (x1, y1)) - in result - -fromTo1 :: Int -> Int -> [Int] -fromTo1 x0 x1 - | x0 <= x1 = [x0..x1] - | otherwise = [x0,x0-1..x1] - --- | Sort the sequence of two points, in the derived lexicographic order. -sortPointXY :: (PointXY, PointXY) -> (PointXY, PointXY) -sortPointXY (a, b) | a <= b = (a, b) - | otherwise = (b, a) - --- | See . -balancedWord :: Int -> Int -> Int -> [Int] -balancedWord p q eps | eps + p < q = 0 : balancedWord p q (eps + p) -balancedWord p q eps = 1 : balancedWord p q (eps + p - q) - --- | Bresenham's line algorithm generalized to arbitrary starting @eps@ --- (@eps@ value of 0 gives the standard BLA). Includes the source point --- and goes through the target point to infinity. -blaXY :: Int -> PointXY -> PointXY -> [PointXY] -blaXY eps (PointXY (x0, y0)) (PointXY (x1, y1)) = - let (dx, dy) = (x1 - x0, y1 - y0) - xyStep b (x, y) = (x + signum dx, y + signum dy * b) - yxStep b (x, y) = (x + signum dx * b, y + signum dy) - (p, q, step) | abs dx > abs dy = (abs dy, abs dx, xyStep) - | otherwise = (abs dx, abs dy, yxStep) - bw = balancedWord p q (eps `mod` max 1 q) - walk w xy = xy : walk (tail w) (step (head w) xy) - in L.map PointXY $ walk bw (x0, y0) - --- | Checks that a point belongs to an area. -insideXY :: PointXY -> (X, Y, X, Y) -> Bool -insideXY (PointXY (x, y)) (x0, y0, x1, y1) = - x1 >= x && x >= x0 && y1 >= y && y >= y0 diff --git a/Game/LambdaHack/Common/Random.hs b/Game/LambdaHack/Common/Random.hs --- a/Game/LambdaHack/Common/Random.hs +++ b/Game/LambdaHack/Common/Random.hs @@ -17,17 +17,15 @@ , rndToIO ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Control.Monad.State as St import Data.Binary -import qualified Data.Binary as Binary import qualified Data.Hashable as Hashable -import qualified Data.List as L import Data.Ratio import GHC.Generics (Generic) import qualified System.Random as R -import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency -- | The monad of computations with random generator state. @@ -59,7 +57,7 @@ -- | Dice: 1d7, 3d3, 1d0, etc. -- @RollDice a b@ represents @a@ rolls of @b@-sided die. -data RollDice = RollDice !Binary.Word8 !Binary.Word8 +data RollDice = RollDice !Word8 !Word8 deriving (Eq, Ord, Generic) instance Show RollDice where @@ -67,7 +65,7 @@ instance Read RollDice where readsPrec d s = - let (a, db) = L.break (== 'd') s + let (a, db) = break (== 'd') s av = read a in case db of 'd' : b -> [ (RollDice av bv, rest) | (bv, rest) <- readsPrec d b ] @@ -84,7 +82,7 @@ -- | Cast dice and sum the results. castDice :: RollDice -> Rnd Int -castDice (RollDice a' 1) = return $ fromEnum a' -- optimization +castDice (RollDice a' 1) = return $! fromEnum a' -- optimization castDice (RollDice a' b') = let (a, b) = (fromEnum a', fromEnum b') in liftM sum (replicateM a (cast b)) @@ -139,8 +137,10 @@ -- To the result of rolling the first set of dice we add the second, -- scaled in proportion to current depth divided by maximal dungeon depth. data RollDeep = RollDeep !RollDice !RollDice - deriving Show + deriving (Show, Eq, Ord, Generic) +instance Binary RollDeep + rollDeep :: (Int, Int) -> (Int, Int) -> RollDeep rollDeep (a, b) (c, d) = RollDeep (rollDice a b) (rollDice c d) @@ -154,7 +154,7 @@ `twith` (n, depth)) skip r1 <- castDice d1 r2 <- castDice d2 - return $ r1 + ((n - 1) * r2) `div` max 1 (depth - 1) + return $! r1 + ((n - 1) * r2) `div` max 1 (depth - 1) -- | Cast dice scaled with current level depth and return @True@ -- if the results if greater than 50. @@ -163,15 +163,16 @@ let n = abs n' depth = abs depth' c <- castDeep n depth deep - return $ c > 50 + return $! c > 50 -- | Generate a @RollDeep@ that always gives a constant integer. intToDeep :: Int -> RollDeep intToDeep 0 = RollDeep (RollDice 0 0) (RollDice 0 0) -intToDeep n' = let n = toEnum n' - in if n > maxBound || n < minBound - then assert `failure` "Deep out of bound" `twith` n' - else RollDeep (RollDice n 1) (RollDice 0 0) +intToDeep n' = if n' > fromEnum (maxBound :: Word8) + || n' < fromEnum (minBound :: Word8) + then assert `failure` "Deep out of bound" `twith` n' + else let n = toEnum n' + in RollDeep (RollDice n 1) (RollDice 0 0) -- | Maximal value of scaled dice. maxDeep :: RollDeep -> Int diff --git a/Game/LambdaHack/Common/Save.hs b/Game/LambdaHack/Common/Save.hs --- a/Game/LambdaHack/Common/Save.hs +++ b/Game/LambdaHack/Common/Save.hs @@ -45,7 +45,9 @@ ms <- takeMVar toSave case ms of Just s -> do - encodeEOF (saveFile s) s + dataDir <- appDataDir + tryCreateDir (dataDir "saves") + encodeEOF (dataDir "saves" saveFile s) s -- Wait until the save finished. During that time, the mvar -- is continually updated to newest state values. loop @@ -77,14 +79,14 @@ -- | Restore a saved game, if it exists. Initialize directory structure -- and cope over data files, if needed. restoreGame :: Binary a - => String -> FilePath - -> [(FilePath, FilePath)] -> (FilePath -> IO FilePath) + => String -> [(FilePath, FilePath)] -> (FilePath -> IO FilePath) -> IO (Maybe a) -restoreGame name configAppDataDir copies pathsDataFile = do +restoreGame name copies pathsDataFile = do -- Create user data directory and copy files, if not already there. - tryCreateDir configAppDataDir - tryCopyDataFiles configAppDataDir pathsDataFile copies - let saveFile = configAppDataDir name + dataDir <- appDataDir + tryCreateDir dataDir + tryCopyDataFiles dataDir pathsDataFile copies + let saveFile = dataDir "saves" name saveExists <- doesFileExist saveFile -- If the savefile exists but we get IO or decoding errors, -- we show them and start a new game. If the savefile was randomly @@ -99,7 +101,7 @@ let handler :: Ex.SomeException -> IO (Maybe a) handler e = do let msg = "Restore failed. The error message is:" - <+> (T.unwords . T.lines) (showT e) + <+> (T.unwords . T.lines) (tshow e) delayPrint $ msg return Nothing either handler return res diff --git a/Game/LambdaHack/Common/ServerCmd.hs b/Game/LambdaHack/Common/ServerCmd.hs --- a/Game/LambdaHack/Common/ServerCmd.hs +++ b/Game/LambdaHack/Common/ServerCmd.hs @@ -2,7 +2,7 @@ -- See -- . module Game.LambdaHack.Common.ServerCmd - ( CmdSer(..), CmdSerTakeTime(..), aidCmdSer, aidCmdSerTakeTime + ( CmdSer(..), CmdTakeTimeSer(..), aidCmdSer, aidCmdTakeTimeSer , FailureSer(..), showFailureSer ) where @@ -18,76 +18,84 @@ -- | Abstract syntax of server commands. data CmdSer = - TakeTimeSer !CmdSerTakeTime - | GameRestartSer !ActorId !Text - | GameExitSer !ActorId + CmdTakeTimeSer !CmdTakeTimeSer + | GameRestartSer !ActorId !Text !Int ![(Int, Text)] + | GameExitSer !ActorId !Int | GameSaveSer !ActorId deriving (Show, Eq) -data CmdSerTakeTime = +data CmdTakeTimeSer = MoveSer !ActorId !Vector | MeleeSer !ActorId !ActorId | DisplaceSer !ActorId !ActorId | AlterSer !ActorId !Point !(Maybe F.Feature) | WaitSer !ActorId - | PickupSer !ActorId !ItemId !Int !InvChar - | DropSer !ActorId !ItemId + | PickupSer !ActorId !ItemId !Int + | DropSer !ActorId !ItemId !Int | ProjectSer !ActorId !Point !Int !ItemId !Container | ApplySer !ActorId !ItemId !Container | TriggerSer !ActorId !(Maybe F.Feature) - | SetPathSer !ActorId ![Vector] + | SetTrajectorySer !ActorId deriving (Show, Eq) --- | The actor that start performing the command (may be dead, after +-- | The actor that starts performing the command (may be dead, after -- the command is performed). aidCmdSer :: CmdSer -> ActorId aidCmdSer cmd = case cmd of - TakeTimeSer cmd2 -> aidCmdSerTakeTime cmd2 - GameRestartSer aid _ -> aid - GameExitSer aid -> aid + CmdTakeTimeSer cmd2 -> aidCmdTakeTimeSer cmd2 + GameRestartSer aid _ _ _ -> aid + GameExitSer aid _ -> aid GameSaveSer aid -> aid -aidCmdSerTakeTime :: CmdSerTakeTime -> ActorId -aidCmdSerTakeTime cmd = case cmd of +aidCmdTakeTimeSer :: CmdTakeTimeSer -> ActorId +aidCmdTakeTimeSer cmd = case cmd of MoveSer aid _ -> aid MeleeSer aid _ -> aid DisplaceSer aid _ -> aid AlterSer aid _ _ -> aid WaitSer aid -> aid - PickupSer aid _ _ _ -> aid - DropSer aid _ -> aid + PickupSer aid _ _ -> aid + DropSer aid _ _ -> aid ProjectSer aid _ _ _ _ -> aid ApplySer aid _ _ -> aid TriggerSer aid _ -> aid - SetPathSer aid _ -> aid + SetTrajectorySer aid -> aid data FailureSer = MoveNothing + | MeleeSelf | MeleeDistant | DisplaceDistant | DisplaceAccess + | DisplaceProjectiles | AlterDistant | AlterBlockActor | AlterBlockItem | AlterNothing + | PickupOverfull | ProjectAimOnself | ProjectBlockTerrain | ProjectBlockActor | ProjectBlockFoes + | ProjectBlind | TriggerNothing showFailureSer :: FailureSer -> Msg showFailureSer failureSer = case failureSer of MoveNothing -> "wasting time on moving into obstacle" + MeleeSelf -> "trying to melee oneself" MeleeDistant -> "trying to melee a distant foe" DisplaceDistant -> "trying to switch places with a distant actor" DisplaceAccess -> "switching places without access" + DisplaceProjectiles -> "trying to switch places with multiple projectiles" AlterDistant -> "trying to alter a distant tile" AlterBlockActor -> "blocked by an actor" AlterBlockItem -> "jammed by an item" AlterNothing -> "wasting time on altering nothing" + PickupOverfull -> "cannot carry any more" ProjectAimOnself -> "cannot aim at oneself" ProjectBlockTerrain -> "aiming obstructed by terrain" ProjectBlockActor -> "aiming blocked by an actor" ProjectBlockFoes -> "aiming interrupted by foes" + ProjectBlind -> "blind actors cannot aim" TriggerNothing -> "wasting time on triggering nothing" diff --git a/Game/LambdaHack/Common/State.hs b/Game/LambdaHack/Common/State.hs --- a/Game/LambdaHack/Common/State.hs +++ b/Game/LambdaHack/Common/State.hs @@ -8,7 +8,7 @@ , defStateGlobal, emptyState, localFromGlobal , updateDungeon, updateDepth, updateActorD, updateItemD , updateFaction, updateTime, updateCOps, getLocalTime - , isSpawnFaction, isSummonFaction + , isSpawnFaction ) where import Data.Binary @@ -21,7 +21,7 @@ import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.PointXY +import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Utils.Frequency @@ -44,17 +44,18 @@ -- TODO: add a flag 'fresh' and when saving levels, don't save -- and when loading regenerate this level. unknownLevel :: Kind.Ops TileKind -> Int -> X -> Y - -> Text -> ([Point], [Point]) -> Int -> Int -> Int + -> Text -> ([Point], [Point]) -> Int -> Int -> Int -> Bool -> Level unknownLevel Kind.Ops{ouniqGroup} ldepth lxsize lysize ldesc lstair lclear - lsecret lhidden = + lsecret lhidden lescape = let unknownId = ouniqGroup "unknown space" + outerId = ouniqGroup "basic outer fence" in Level { ldepth , lprio = EM.empty , lfloor = EM.empty - , ltile = unknownTileMap unknownId lxsize lysize - , lxsize = lxsize - , lysize = lysize + , ltile = unknownTileMap unknownId outerId lxsize lysize + , lxsize + , lysize , lsmell = EM.empty , ldesc , lstair @@ -65,12 +66,18 @@ , litemFreq = toFreq "client item freq" [] , lsecret , lhidden + , lescape } -unknownTileMap :: Kind.Id TileKind -> Int -> Int -> TileMap -unknownTileMap unknownId cxsize cysize = - let bounds = (origin, toPoint cxsize $ PointXY (cxsize - 1, cysize - 1)) - in Kind.listArray bounds (repeat unknownId) +unknownTileMap :: Kind.Id TileKind -> Kind.Id TileKind -> Int -> Int -> TileMap +unknownTileMap unknownId outerId lxsize lysize = + let unknownMap = PointArray.replicateA lxsize lysize unknownId + borders = [ Point x y + | x <- [0, lxsize - 1], y <- [1..lysize - 2] ] + ++ [ Point x y + | x <- [0..lxsize - 1], y <- [0, lysize - 1] ] + outerUpdate = zip borders $ repeat outerId + in unknownMap PointArray.// outerUpdate -- | Initial complete global game state. defStateGlobal :: Dungeon -> Int @@ -109,7 +116,7 @@ { _sdungeon = EM.map (\Level{..} -> unknownLevel cotile ldepth lxsize lysize ldesc lstair lclear - lsecret lhidden) + lsecret lhidden lescape) _sdungeon , .. } @@ -148,11 +155,7 @@ -- | Tell whether the faction can spawn actors. isSpawnFaction :: FactionId -> State -> Bool -isSpawnFaction fid s = isSpawnFact (_scops s) $ _sfactionD s EM.! fid - --- | Tell whether actors of the faction can be summoned by items, etc.. -isSummonFaction :: FactionId -> State -> Bool -isSummonFaction fid s = isSummonFact (_scops s) $ _sfactionD s EM.! fid +isSpawnFaction fid s = isSpawnFact $ _sfactionD s EM.! fid sdungeon :: State -> Dungeon sdungeon = _sdungeon @@ -196,4 +199,4 @@ _stime <- get _shigh <- get let _scops = undefined -- overwritten by recreated cops - return State{..} + return $! State{..} diff --git a/Game/LambdaHack/Common/Tile.hs b/Game/LambdaHack/Common/Tile.hs --- a/Game/LambdaHack/Common/Tile.hs +++ b/Game/LambdaHack/Common/Tile.hs @@ -14,21 +14,22 @@ -- Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m). module Game.LambdaHack.Common.Tile ( SmellTime - , kindHasFeature, kindHas, hasFeature - , isClear, isLit, isExplorable, similar, speedup - , openTo, closeTo, revealAs, hideAs, openable, closable, changeable + , kindHasFeature, hasFeature + , isClear, isLit, isWalkable, isPassable, isDoor, isSuspect + , isExplorable, lookSimilar, speedup + , openTo, closeTo, causeEffects, revealAs, hideAs + , isOpenable, isClosable, isChangeable, isEscape, isStair ) where -import qualified Data.Array.Unboxed as A -import qualified Data.List as L +import Control.Exception.Assert.Sugar import Data.Maybe +import qualified Game.LambdaHack.Common.Effect as Effect import qualified Game.LambdaHack.Common.Feature as F import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.TileKind -import Control.Exception.Assert.Sugar -- | The last time a hero left a smell in a given tile. To be used -- by monsters that hunt by smell. @@ -36,57 +37,101 @@ -- | Whether a tile kind has the given feature. kindHasFeature :: F.Feature -> TileKind -> Bool +{-# INLINE kindHasFeature #-} kindHasFeature f t = f `elem` tfeature t --- | Whether a tile kind has all features of the first set --- and no features of the second. -kindHas :: [F.Feature] -> [F.Feature] -> TileKind -> Bool -kindHas yes no t = L.all (`kindHasFeature` t) yes - && not (L.any (`kindHasFeature` t) no) - -- | Whether a tile kind (specified by its id) has the given feature. hasFeature :: Kind.Ops TileKind -> F.Feature -> Kind.Id TileKind -> Bool -hasFeature Kind.Ops{okind} f t = - kindHasFeature f (okind t) +{-# INLINE hasFeature #-} +hasFeature Kind.Ops{okind} f t = kindHasFeature f (okind t) -- | Whether a tile does not block vision. -- Essential for efficiency of "FOV", hence tabulated. isClear :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool -isClear Kind.Ops{ospeedup = Just Kind.TileSpeedup{isClearTab}} = isClearTab +{-# INLINE isClear #-} +isClear Kind.Ops{ospeedup = Just Kind.TileSpeedup{isClearTab}} = + \k -> Kind.accessTab isClearTab k isClear cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile -- | Whether a tile is lit on its own. -- Essential for efficiency of "Perception", hence tabulated. isLit :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool -isLit Kind.Ops{ospeedup = Just Kind.TileSpeedup{isLitTab}} = isLitTab +{-# INLINE isLit #-} +isLit Kind.Ops{ospeedup = Just Kind.TileSpeedup{isLitTab}} = + \k -> Kind.accessTab isLitTab k isLit cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile --- | Whether a tile can be explored, possibly yielding a treasure --- or a hidden message. +-- | Whether actors can walk into a tile. +-- Essential for efficiency of pathfinding, hence tabulated. +isWalkable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool +{-# INLINE isWalkable #-} +isWalkable Kind.Ops{ospeedup = Just Kind.TileSpeedup{isWalkableTab}} = + \k -> Kind.accessTab isWalkableTab k +isWalkable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile + +-- | Whether actors can walk into a tile, perhaps opening a door first. +-- Essential for efficiency of pathfinding, hence tabulated. +isPassable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool +{-# INLINE isPassable #-} +isPassable Kind.Ops{ospeedup = Just Kind.TileSpeedup{isPassableTab}} = + \k -> Kind.accessTab isPassableTab k +isPassable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile + +-- | Whether a tile is a door, open or closed. +-- Essential for efficiency of pathfinding, hence tabulated. +isDoor :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool +{-# INLINE isDoor #-} +isDoor Kind.Ops{ospeedup = Just Kind.TileSpeedup{isDoorTab}} = + \k -> Kind.accessTab isDoorTab k +isDoor cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile + +-- | Whether a tile is suspect. +-- Essential for efficiency of pathfinding, hence tabulated. +isSuspect :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool +{-# INLINE isSuspect #-} +isSuspect Kind.Ops{ospeedup = Just Kind.TileSpeedup{isSuspectTab}} = + \k -> Kind.accessTab isSuspectTab k +isSuspect cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile + +-- | Whether a tile can be explored, possibly yielding a treasure. +-- Note that non-walkable tiles can hold treasure, e.g., caches. isExplorable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool -isExplorable cops tk = isClear cops tk || hasFeature cops F.Walkable tk +{-# INLINE isExplorable #-} +isExplorable cotile t = + isWalkable cotile t || isDoor cotile t || isChangeable cotile t -- | The player can't tell one tile from the other. -similar :: TileKind -> TileKind -> Bool -similar t u = +lookSimilar :: TileKind -> TileKind -> Bool +{-# INLINE lookSimilar #-} +lookSimilar t u = tsymbol t == tsymbol u && tname t == tname u && tcolor t == tcolor u && tcolor2 t == tcolor2 u speedup :: Bool -> Kind.Ops TileKind -> Kind.Speedup TileKind -speedup allClear Kind.Ops{ofoldrWithKey, obounds} = - let createTab :: (TileKind -> Bool) -> A.UArray (Kind.Id TileKind) Bool - createTab p = - let f _ k acc = p k : acc - clearAssocs = ofoldrWithKey f [] - in A.listArray obounds clearAssocs - tabulate :: (TileKind -> Bool) -> Kind.Id TileKind -> Bool - tabulate p = (createTab p A.!) - isClearTab | allClear = tabulate $ not . kindHasFeature F.Impenetrable - | otherwise = tabulate $ kindHasFeature F.Clear - isLitTab = tabulate $ kindHasFeature F.Lit - in Kind.TileSpeedup {isClearTab, isLitTab} +speedup allClear cotile = + -- Vectors pack bools as Word8 by default. No idea if the extra memory + -- taken makes random lookups more or less efficient, so not optimizing + -- further, until I have benchmarks. + let isClearTab | allClear = Kind.createTab cotile + $ not . kindHasFeature F.Impenetrable + | otherwise = Kind.createTab cotile + $ kindHasFeature F.Clear + isLitTab = Kind.createTab cotile $ not . kindHasFeature F.Dark + isWalkableTab = Kind.createTab cotile $ kindHasFeature F.Walkable + isPassableTab = Kind.createTab cotile $ \tk -> + let getTo F.OpenTo{} = True + getTo F.Walkable = True + getTo _ = False + in any getTo $ tfeature tk + isDoorTab = Kind.createTab cotile $ \tk -> + let getTo F.OpenTo{} = True + getTo F.CloseTo{} = True + getTo _ = False + in any getTo $ tfeature tk + isSuspectTab = Kind.createTab cotile $ kindHasFeature F.Suspect + in Kind.TileSpeedup {..} openTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) openTo Kind.Ops{okind, opick} t = do @@ -110,6 +155,12 @@ fmap (fromMaybe $ assert `failure` group) $ opick group (const True) +causeEffects :: Kind.Ops TileKind -> Kind.Id TileKind -> [Effect.Effect Int] +causeEffects Kind.Ops{okind} t = do + let getTo (F.Cause eff) acc = eff : acc + getTo _ acc = acc + foldr getTo [] $ tfeature $ okind t + revealAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) revealAs Kind.Ops{okind, opick} t = do let getTo (F.RevealAs group) acc = group : acc @@ -129,23 +180,33 @@ Nothing -> t Just group -> ouniqGroup group --- | Whether a tile kind (specified by its id) has a OpenTo feature. -openable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool -openable Kind.Ops{okind} t = +-- | Whether a tile kind (specified by its id) has an OpenTo feature. +isOpenable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool +isOpenable Kind.Ops{okind} t = let getTo F.OpenTo{} = True getTo _ = False in any getTo $ tfeature $ okind t -- | Whether a tile kind (specified by its id) has a CloseTo feature. -closable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool -closable Kind.Ops{okind} t = +isClosable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool +isClosable Kind.Ops{okind} t = let getTo F.CloseTo{} = True getTo _ = False in any getTo $ tfeature $ okind t -- | Whether a tile kind (specified by its id) has a ChangeTo feature. -changeable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool -changeable Kind.Ops{okind} t = +isChangeable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool +isChangeable Kind.Ops{okind} t = let getTo F.ChangeTo{} = True getTo _ = False in any getTo $ tfeature $ okind t + +isEscape :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool +isEscape cotile t = let isEffectEscape Effect.Escape{} = True + isEffectEscape _ = False + in any isEffectEscape $ causeEffects cotile t + +isStair :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool +isStair cotile t = let isEffectAscend Effect.Ascend{} = True + isEffectAscend _ = False + in any isEffectAscend $ causeEffects cotile t diff --git a/Game/LambdaHack/Common/Time.hs b/Game/LambdaHack/Common/Time.hs --- a/Game/LambdaHack/Common/Time.hs +++ b/Game/LambdaHack/Common/Time.hs @@ -5,13 +5,15 @@ , timeAdd, timeFit, timeNegate, timeScale, timeEpsilon , timeToDigit , Speed, toSpeed, speedZero, speedNormal, speedScale, speedAdd, speedNegate - , ticksPerMeter, traveled, speedFromWeight, rangeFromSpeed + , ticksPerMeter, speedFromWeight, rangeFromSpeed ) where import Data.Binary import qualified Data.Char as Char import Data.Int (Int64) +import Game.LambdaHack.Common.Misc + -- | Game time in ticks. The time dimension. -- One tick is 1 microsecond (one millionth of a second), -- one turn is 0.5 s. @@ -100,7 +102,7 @@ put (Speed n) = put n get = fmap Speed get --- | Number of seconds in a kilo-second. +-- | Number of seconds in a mega-second. sInMs :: Int64 sInMs = 1000000 @@ -130,13 +132,7 @@ -- | The number of time ticks it takes to walk 1 meter at the given speed. ticksPerMeter :: Speed -> Time -ticksPerMeter (Speed v) = Time $ _ticksInSecond * sInMs `div` v - --- | Distance in meters (so also in tiles, given the chess metric) --- traveled in a given time by a body with a given speed. -traveled :: Speed -> Time -> Int -traveled (Speed v) (Time t) = - fromIntegral $ v * t `div` (_ticksInSecond * sInMs) +ticksPerMeter (Speed v) = Time $ _ticksInSecond * sInMs `divUp` v -- | Calculate projectile speed from item weight in grams -- and speed bonus in percents. @@ -148,13 +144,16 @@ mpMs | w <= 500 = sInMs * 16 | w > 500 && w <= 2000 = sInMs * 16 * 1500 `div` (w + 1000) | otherwise = sInMs * (10000 - w) `div` 1000 - in Speed $ max 0 $ mpMs * (100 + b) `div` 100 + in Speed $ max 1 $ mpMs * (100 + b) `div` 100 -- | Calculate maximum range in meters of a projectile from its speed. -- See . --- With this formula, each projectile flies for exactly one second, +-- With this formula, each projectile flies for at most 1 second, -- that is 2 turns, and then drops to the ground. --- Dividing and multiplying by 2 ensures both turns of flight --- cover the same distance. +-- We round down to the nearest multiple of 2 (unless the speed +-- is very low), to ensure both turns of flight cover the same distance. rangeFromSpeed :: Speed -> Int -rangeFromSpeed (Speed v) = fromIntegral $ 2 * (v `div` (sInMs * 2)) +rangeFromSpeed (Speed v) = + fromIntegral $ if v >= 2 * sInMs + then 2 * (v `div` (2 * sInMs)) + else v `div` sInMs diff --git a/Game/LambdaHack/Common/Vector.hs b/Game/LambdaHack/Common/Vector.hs --- a/Game/LambdaHack/Common/Vector.hs +++ b/Game/LambdaHack/Common/Vector.hs @@ -1,131 +1,206 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Basic operations on 2D vectors represented in an efficient, -- but not unique, way. module Game.LambdaHack.Common.Vector - ( Vector, toVector, toDir, shift, shiftBounded, moves - , isUnit, euclidDistSq, diagonal, neg, towards, displacement - , displacePath, shiftPath + ( Vector(..), isUnit, isDiagonal, neg, chessDistVector, euclidDistSqVector + , moves, compassText, vicinity, vicinityCardinal + , shift, shiftBounded, trajectoryToPath, displacement, pathToTrajectory + , RadianAngle, rotate, towards + , BfsDistance, MoveLegal(..), apartBfs + , fillBfs, findPathBfs, accessBfs, posAimsPos ) where +import Control.Arrow (second) +import Control.Exception.Assert.Sugar import Data.Binary +import Data.Bits (Bits, complement, (.&.), (.|.)) +import qualified Data.EnumMap.Strict as EM +import Data.Int (Int32) +import Data.List +import Data.Maybe +import qualified Data.Sequence as Seq +import Data.Text (Text) import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.PointXY -import Game.LambdaHack.Common.VectorXY -import Control.Exception.Assert.Sugar +import qualified Game.LambdaHack.Common.PointArray as PointArray --- | 2D vectors represented as offsets in the linear framebuffer --- indexed by 'Point'. --- --- A newtype is used to prevent mixing up the type with @Point@ itself. --- Note that the offset representations of a vector is usually not unique. --- E.g., for vectors of length 1 in the chessboard metric, used to denote --- geographical directions, the representations are pairwise distinct --- if and only if the level width and height are at least 3. -newtype Vector = Vector Int - deriving (Eq, Ord, Read) +-- | 2D vectors in cartesian representation. Coordinates grow to the right +-- and down, so that the (1, 1) vector points to the bottom-right corner +-- of the screen. +data Vector = Vector + { vx :: !X + , vy :: !Y + } + deriving (Eq, Ord, Show, Read) instance Binary Vector where - put (Vector dir) = put dir - get = fmap Vector get + put = put . (fromIntegral :: Int -> Int32) . fromEnum + get = fmap (toEnum . (fromIntegral :: Int32 -> Int)) get --- For debugging. -instance Show Vector where - show (Vector n) = show n +instance Enum Vector where + fromEnum = fromEnumVector + toEnum = toEnumVector --- | Converts a vector in cartesian representation into @Vector@. -toVector :: X -> VectorXY -> Vector -toVector lxsize (VectorXY (x, y)) = - Vector $ x + y * lxsize +-- | Maximal supported vector X and Y coordinates. +maxVectorDim :: Int +{-# INLINE maxVectorDim #-} +maxVectorDim = 2 ^ (maxLevelDimExponent - 1) - 1 -isUnitXY :: VectorXY -> Bool -isUnitXY v = chessDistXY v == 1 +fromEnumVector :: Vector -> Int +{-# INLINE fromEnumVector #-} +fromEnumVector (Vector vx vy) = vx + vy * (2 ^ maxLevelDimExponent) +toEnumVector :: Int -> Vector +{-# INLINE toEnumVector #-} +toEnumVector n = + let (y, x) = n `quotRem` (2 ^ maxLevelDimExponent) + (vx, vy) = if x > maxVectorDim + then (x - 2 ^ maxLevelDimExponent, y + 1) + else if x < - maxVectorDim + then (x + 2 ^ maxLevelDimExponent, y - 1) + else (x, y) + in Vector{..} + -- | Tells if a vector has length 1 in the chessboard metric. -isUnit :: X -> Vector -> Bool -isUnit lxsize = isUnitXY . fromDir lxsize +isUnit :: Vector -> Bool +{-# INLINE isUnit #-} +isUnit v = chessDistVector v == 1 --- | Converts a unit vector in cartesian representation into @Vector@. -toDir :: X -> VectorXY -> Vector -toDir lxsize v@(VectorXY (x, y)) = - assert (lxsize >= 3 && isUnitXY v `blame` "ambiguous XY vector conversion" - `twith` (lxsize, v)) $ - Vector $ x + y * lxsize +-- | Checks whether a unit vector is a diagonal direction, +-- as opposed to cardinal. If the vector is not unit, +-- it checks that the vector is not horizontal nor vertical. +isDiagonal :: Vector -> Bool +{-# INLINE isDiagonal #-} +isDiagonal (Vector x y) = x * y /= 0 --- | Converts a unit vector in the offset representation --- into the cartesian representation. Arbitrary vectors can't be --- converted uniquely. -fromDir :: X -> Vector -> VectorXY -fromDir lxsize (Vector dir) = - assert (lxsize >= 3 && isUnitXY res && - fst len1 + snd len1 * lxsize == dir - `blame` "ambiguous vector conversion" `twith` (lxsize, dir, res)) - res - where - (x, y) = (dir `mod` lxsize, dir `div` lxsize) - -- Pick the vector's canonical form of length 1: - len1 = if x > 1 - then (x - lxsize, y + 1) - else (x, y) - res = VectorXY len1 +-- | Reverse an arbirary vector. +neg :: Vector -> Vector +{-# INLINE neg #-} +neg (Vector vx vy) = Vector (-vx) (-vy) +-- | Squared euclidean distance between two vectors. +euclidDistSqVector :: Vector -> Vector -> Int +{-# INLINE euclidDistSqVector #-} +euclidDistSqVector (Vector x0 y0) (Vector x1 y1) = + let square n = n ^ (2 :: Int) + in square (x1 - x0) + square (y1 - y0) + +-- | The lenght of a vector in the chessboard metric, +-- where diagonal moves cost 1. +chessDistVector :: Vector -> Int +{-# INLINE chessDistVector #-} +chessDistVector (Vector x y) = max (abs x) (abs y) + +-- | Vectors of all unit moves in the chessboard metric, +-- clockwise, starting north-west. +moves :: [Vector] +moves = + map (uncurry Vector) + [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)] + +moveTexts :: [Text] +moveTexts = ["NW", "N", "NE", "E", "SE", "S", "SW", "W"] + +compassText :: Vector -> Text +compassText v = let m = EM.fromList $ zip moves moveTexts + in fromMaybe (assert `failure` "not a unit vector" + `twith` v) $ EM.lookup v m + +-- | Vectors of all cardinal direction unit moves, clockwise, starting north. +movesCardinal :: [Vector] +movesCardinal = map (uncurry Vector) [(0, -1), (1, 0), (0, 1), (-1, 0)] + +-- | All (8 at most) closest neighbours of a point within an area. +vicinity :: X -> Y -- ^ limit the search to this area + -> Point -- ^ position to find neighbours of + -> [Point] +vicinity lxsize lysize p = + [ res | dxy <- moves + , let res = shift p dxy + , inside res (0, 0, lxsize - 1, lysize - 1) ] + +-- | All (4 at most) cardinal direction neighbours of a point within an area. +vicinityCardinal :: X -> Y -- ^ limit the search to this area + -> Point -- ^ position to find neighbours of + -> [Point] +vicinityCardinal lxsize lysize p = + [ res | dxy <- movesCardinal + , let res = shift p dxy + , inside res (0, 0, lxsize - 1, lysize - 1) ] + -- | Translate a point by a vector. --- --- Particularly simple and fast implementation in the linear representation. shift :: Point -> Vector -> Point -shift p (Vector dir) = toEnum $ fromEnum p + dir +{-# INLINE shift #-} +shift (Point x0 y0) (Vector x1 y1) = Point (x0 + x1) (y0 + y1) -- | Translate a point by a vector, but only if the result fits in an area. -shiftBounded :: X -> (X, Y, X, Y) -> Point -> Vector -> Point -shiftBounded lxsize area pos dir = - let res = shift pos dir - in if inside lxsize res area then res else pos +shiftBounded :: X -> Y -> Point -> Vector -> Point +shiftBounded lxsize lysize pos v@(Vector xv yv) = + if inside pos (-xv, -yv, lxsize - xv - 1, lysize - yv - 1) + then shift pos v + else pos --- | Vectors of all unit moves, clockwise, starting north-west. -moves :: X -> [Vector] -moves lxsize = map (toDir lxsize) movesXY +-- | A list of points that a list of vectors leads to. +trajectoryToPath :: Point -> [Vector] -> [Point] +trajectoryToPath _ [] = [] +trajectoryToPath start (v : vs) = let next = shift start v + in next : trajectoryToPath next vs --- | Squared euclidean distance between two unit vectors. -euclidDistSq :: X -> Vector -> Vector -> Int -euclidDistSq lxsize dir0 dir1 - | VectorXY (x0, y0) <- fromDir lxsize dir0 - , VectorXY (x1, y1) <- fromDir lxsize dir1 = - euclidDistSqXY $ VectorXY (x1 - x0, y1 - y0) +-- | A vector from a point to another. We have +-- +-- > shift pos1 (displacement pos1 pos2) == pos2 +displacement :: Point -> Point -> Vector +{-# INLINE displacement #-} +displacement (Point x0 y0) (Point x1 y1) = Vector (x1 - x0) (y1 - y0) --- | Checks whether a unit vector is a diagonal direction, --- as opposed to cardinal. If the vector is not unit, --- it reject horizontal and vertical vectors. -diagonal :: X -> Vector -> Bool -diagonal lxsize dir | VectorXY (x, y) <- fromDir lxsize dir = - x * y /= 0 +-- | A list of vectors between a list of points. +pathToTrajectory :: [Point] -> [Vector] +pathToTrajectory [] = [] +pathToTrajectory lp1@(_ : lp2) = zipWith displacement lp1 lp2 --- | Reverse an arbirary vector. -neg :: Vector -> Vector -neg (Vector dir) = Vector (-dir) +type RadianAngle = Double +-- | Rotate a vector by the given angle (expressed in radians) +-- counterclockwise and return a unit vector approximately in the resulting +-- direction. +rotate :: RadianAngle -> Vector -> Vector +rotate angle (Vector x' y') = + let x = fromIntegral x' + y = fromIntegral y' + -- Minus before the angle comes from our coordinates being + -- mirrored along the X axis (Y coordinates grow going downwards). + dx = x * cos (-angle) - y * sin (-angle) + dy = x * sin (-angle) + y * cos (-angle) + in normalize dx dy + -- TODO: use bla for that -- | Given a vector of arbitrary non-zero length, produce a unit vector -- that points in the same direction (in the chessboard metric). -- Of several equally good directions it picks one of those that visually -- (in the euclidean metric) maximally align with the original vector. -normalize :: X -> VectorXY -> Vector -normalize lxsize v@(VectorXY (dx, dy)) = +normalize :: Double -> Double -> Vector +normalize dx dy = assert (dx /= 0 || dy /= 0 `blame` "can't normalize zero" `twith` (dx, dy)) $ let angle :: Double - angle = atan (fromIntegral dy / fromIntegral dx) / (pi / 2) + angle = atan (dy / dx) / (pi / 2) dxy | angle <= -0.75 && angle >= -1.25 = (0, -1) | angle <= -0.25 = (1, -1) | angle <= 0.25 = (1, 0) | angle <= 0.75 = (1, 1) | angle <= 1.25 = (0, 1) | otherwise = assert `failure` "impossible angle" - `twith` (lxsize, dx, dy, angle) - rxy = if dx >= 0 - then VectorXY dxy - else negXY $ VectorXY dxy - in assert (not (isUnitXY v) || v == rxy + `twith` (dx, dy, angle) + in if dx >= 0 + then uncurry Vector dxy + else neg $ uncurry Vector dxy + +normalizeVector :: Vector -> Vector +normalizeVector v@(Vector vx vy) = + let res = normalize (fromIntegral vx) (fromIntegral vy) + in assert (not (isUnit v) || v == res `blame` "unit vector gets untrivially normalized" - `twith` (v, rxy)) - $ toDir lxsize rxy + `twith` (v, res)) + res -- TODO: Perhaps produce all acceptable directions and let AI choose. -- That would also eliminate the Doubles. Or only directions from bla? @@ -137,28 +212,130 @@ -- (in the chessboard metric) it picks one of those that visually -- (in the euclidean metric) maximally align with the vector between -- the two points. -towards :: X -> Point -> Point -> Vector -towards lxsize pos0 pos1 = - assert (pos0 /= pos1 `blame` "towards self" `twith` (pos0, pos1)) $ - let v = displacementXYZ lxsize pos0 pos1 - in normalize lxsize v +towards :: Point -> Point -> Vector +towards pos0 pos1 = + assert (pos0 /= pos1 `blame` "towards self" `twith` (pos0, pos1)) + $ normalizeVector $ displacement pos0 pos1 --- | A vector from a point to another. We have --- --- > shift pos1 (displacement pos1 pos2) == pos2 --- --- Particularly simple and fast implementation in the linear representation. -displacement :: Point -> Point -> Vector -displacement pos1 pos2 = Vector $ fromEnum pos2 - fromEnum pos1 +newtype BfsDistance = BfsDistance Word8 + deriving (Show, Eq, Ord, Enum, Bounded, Bits) --- | A list of vectors between a list of points. -displacePath :: [Point] -> [Vector] -displacePath [] = [] -displacePath lp1@(_ : lp2) = zipWith displacement lp1 lp2 +data MoveLegal = MoveBlocked | MoveToOpen | MoveToUnknown + deriving Eq --- | A list of points that a list of vectors leads to. -shiftPath :: Point -> [Vector] -> [Point] -shiftPath _ [] = [] -shiftPath start (v : vs) = - let next = shift start v - in next : shiftPath next vs +minKnownBfs :: BfsDistance +minKnownBfs = toEnum $ (1 + fromEnum (maxBound :: BfsDistance)) `div` 2 + +apartBfs :: BfsDistance +apartBfs = pred minKnownBfs + +-- TODO: Move somewhere; in particular, only clients need to know that. +fillBfs :: (Point -> Point -> MoveLegal) -- ^ is move from a known tile legal + -> (Point -> Point -> Bool) -- ^ is a move from unknown legal + -> Point -- ^ starting position + -> PointArray.Array BfsDistance -- ^ initial array, with @apartBfs@ + -> PointArray.Array BfsDistance -- ^ array with calculated distances +fillBfs isEnterable passUnknown origin aInitial = + -- TODO: copy, thaw, mutate, freeze + let maxUnknownBfs = pred apartBfs + maxKnownBfs = pred maxBound + bfs :: Seq.Seq (Point, BfsDistance) + -> PointArray.Array BfsDistance + -> PointArray.Array BfsDistance + bfs q a = + case Seq.viewr q of + Seq.EmptyR -> a -- no more positions to check + _ Seq.:> (_, d) + | d == maxUnknownBfs || d == maxKnownBfs -> a -- too far + q1 Seq.:> (pos, oldDistance) | oldDistance >= minKnownBfs -> + let distance = succ oldDistance + allMvs = map (shift pos) moves + freshMv p = a PointArray.! p == apartBfs + freshMvs = filter freshMv allMvs + legal p = (p, isEnterable pos p) + legalities = map legal freshMvs + notBlocked = filter ((/= MoveBlocked) . snd) legalities + legalToDist l = if l == MoveToOpen + then distance + else distance .&. complement minKnownBfs + mvs = map (second legalToDist) notBlocked + q2 = foldr (Seq.<|) q1 mvs + s2 = a PointArray.// mvs + in bfs q2 s2 + q1 Seq.:> (pos, oldDistance) -> + let distance = succ oldDistance + allMvs = map (shift pos) moves + goodMv p = a PointArray.! p == apartBfs && passUnknown pos p + mvs = zip (filter goodMv allMvs) (repeat distance) + q2 = foldr (Seq.<|) q1 mvs + s2 = a PointArray.// mvs + in bfs q2 s2 + origin0 = (origin, minKnownBfs) + in bfs (Seq.singleton origin0) (aInitial PointArray.// [origin0]) + +-- TODO: Use http://harablog.wordpress.com/2011/09/07/jump-point-search/ +-- to determine a few really different paths and compare them, +-- e.g., how many closed doors they pass, open doors, unknown tiles +-- on the path or close enough to reveal them. +-- Also, check if JPS can somehow optimize BFS or pathBfs. +-- | Find a path, without the source position, with the smallest length. +-- The @eps@ coefficient determines which direction (or the closest +-- directions available) that path should prefer, where 0 means north-west +-- and 1 means north. +findPathBfs :: (Point -> Point -> MoveLegal) + -> (Point -> Point -> Bool) + -> Point -> Point -> Int -> PointArray.Array BfsDistance + -> Maybe [Point] +findPathBfs isEnterable passUnknown source target sepsRaw bfs = + assert (bfs PointArray.! source == minKnownBfs) $ + let targetDist = bfs PointArray.! target + in if targetDist == apartBfs + then Nothing + else + let eps = abs sepsRaw `mod` length moves + mix (x : xs) ys = x : mix ys xs + mix [] ys = ys + preferedMoves = let (ch1, ch2) = splitAt eps moves + ch = ch2 ++ ch1 + in mix ch (reverse ch) + track :: Point -> BfsDistance -> [Point] -> [Point] + track pos oldDist suffix | oldDist == minKnownBfs = + assert (pos == source + `blame` (source, target, pos, suffix)) suffix + track pos oldDist suffix | oldDist > minKnownBfs = + let dist = pred oldDist + children = map (shift pos) preferedMoves + matchesDist p = bfs PointArray.! p == dist + && isEnterable p pos == MoveToOpen + minP = fromMaybe (assert `failure` (pos, oldDist, children)) + (find matchesDist children) + in track minP dist (pos : suffix) + track pos oldDist suffix = + let distUnknown = pred oldDist + distKnown = distUnknown .|. minKnownBfs + children = map (shift pos) preferedMoves + matchesDistUnknown p = bfs PointArray.! p == distUnknown + && passUnknown p pos + matchesDistKnown p = bfs PointArray.! p == distKnown + && isEnterable p pos == MoveToUnknown + (minP, dist) = case find matchesDistKnown children of + Just p -> (p, distKnown) + Nothing -> case find matchesDistUnknown children of + Just p -> (p, distUnknown) + Nothing -> assert `failure` (pos, oldDist, children) + in track minP dist (pos : suffix) + in Just $ track target targetDist [] + +accessBfs :: PointArray.Array BfsDistance -> Point -> Maybe Int +{-# INLINE accessBfs #-} +accessBfs bfs target = + let dist = bfs PointArray.! target + in if dist == apartBfs + then Nothing + else Just $ fromEnum $ dist .&. complement minKnownBfs + +posAimsPos :: PointArray.Array BfsDistance -> Point -> Point -> Bool +{-# INLINE posAimsPos #-} +posAimsPos bfs bpos target = + let mdist = accessBfs bfs target + in mdist == Just (chessDist bpos target) diff --git a/Game/LambdaHack/Common/VectorXY.hs b/Game/LambdaHack/Common/VectorXY.hs deleted file mode 100644 --- a/Game/LambdaHack/Common/VectorXY.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | Basic cartesian geometry operations on 2D vectors. -module Game.LambdaHack.Common.VectorXY - ( VectorXY(..), shiftXY, movesXY, movesCardinalXY - , chessDistXY, euclidDistSqXY, negXY, vicinityXY, vicinityCardinalXY - ) where - -import Data.Binary - -import Game.LambdaHack.Common.PointXY - --- | 2D vectors in cartesian representation. -newtype VectorXY = VectorXY (X, Y) - deriving (Eq, Ord, Show, Read, Binary) - --- | Shift a point by a vector. -shiftXY :: PointXY -> VectorXY -> PointXY -shiftXY (PointXY (x0, y0)) (VectorXY (x1, y1)) = PointXY (x0 + x1, y0 + y1) - --- | Vectors of all unit moves in the chessboard metric, --- clockwise, starting north-west. -movesXY :: [VectorXY] -movesXY = - map VectorXY - [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)] - --- | Vectors of all cardinal direction unit moves, clockwise, starting north. -movesCardinalXY :: [VectorXY] -movesCardinalXY = map VectorXY [(0, -1), (1, 0), (0, 1), (-1, 0)] - --- | The lenght of a vector in the chessboard metric, --- where diagonal moves cost 1. -chessDistXY :: VectorXY -> Int -chessDistXY (VectorXY (x, y)) = max (abs x) (abs y) - --- | Squared euclidean length of a vector. -euclidDistSqXY :: VectorXY -> Int -euclidDistSqXY (VectorXY (x, y)) = x * x + y * y - --- | Reverse an arbirary vector. -negXY :: VectorXY -> VectorXY -negXY (VectorXY (x, y)) = VectorXY (-x, -y) - --- | All (8 at most) closest neighbours of a point within an area. -vicinityXY :: (X, Y, X, Y) -- ^ limit the search to this area - -> PointXY -- ^ position to find neighbours of - -> [PointXY] -vicinityXY area xy = - [ res | dxy <- movesXY, let res = shiftXY xy dxy, insideXY res area ] - --- | All (4 at most) cardinal direction neighbours of a point within an area. -vicinityCardinalXY :: (X, Y, X, Y) -- ^ limit the search to this area - -> PointXY -- ^ position to find neighbours of - -> [PointXY] -vicinityCardinalXY area xy = - [ res - | dxy <- movesCardinalXY, let res = shiftXY xy dxy, insideXY res area ] diff --git a/Game/LambdaHack/Content/ActorKind.hs b/Game/LambdaHack/Content/ActorKind.hs --- a/Game/LambdaHack/Content/ActorKind.hs +++ b/Game/LambdaHack/Content/ActorKind.hs @@ -1,12 +1,13 @@ -- | The type of kinds of monsters and heroes. module Game.LambdaHack.Content.ActorKind - ( ActorKind(..), avalidate + ( ActorKind(..), validateActorKind ) where import Control.Arrow ((&&&)) import Data.List import qualified Data.Ord as Ord import Data.Text (Text) +import qualified Data.Text as T import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Color @@ -35,10 +36,12 @@ -- | Filter a list of kinds, passing through only the incorrect ones, if any. -- -- Make sure actor kinds can be told apart on the level map. -avalidate :: [ActorKind] -> [ActorKind] -avalidate l = +validateActorKind :: [ActorKind] -> [ActorKind] +validateActorKind l = let cmp = Ord.comparing $ asymbol &&& acolor eq ka1 ka2 = cmp ka1 ka2 == Ord.EQ sorted = sortBy cmp l nubbed = nubBy eq sorted - in deleteFirstsBy eq sorted nubbed + tooSimilar = deleteFirstsBy eq sorted nubbed + tooVerbose = filter (\ak -> T.length (aname ak) > 25) l + in tooSimilar ++ tooVerbose diff --git a/Game/LambdaHack/Content/CaveKind.hs b/Game/LambdaHack/Content/CaveKind.hs --- a/Game/LambdaHack/Content/CaveKind.hs +++ b/Game/LambdaHack/Content/CaveKind.hs @@ -1,14 +1,13 @@ -- | The type of cave layout kinds. module Game.LambdaHack.Content.CaveKind - ( CaveKind(..), cvalidate + ( CaveKind(..), validateCaveKind ) where -import qualified Data.List as L import Data.Text (Text) import qualified Data.Text as T import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.PointXY +import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random -- | Parameters for the generation of dungeon levels. @@ -33,10 +32,11 @@ , citemFreq :: ![(Int, Text)] -- ^ item groups to consider , cdefTile :: !Text -- ^ the default cave tile group name , cdarkCorTile :: !Text -- ^ the dark cave corridor tile group name - , clitCorTile :: !Text -- ^ the dark cave corridor tile group name + , clitCorTile :: !Text -- ^ the lit cave corridor tile group name , cfillerTile :: !Text -- ^ the filler wall group name - , cdarkLegendTile :: !Text -- ^ the dark place plan legend ground name - , clitLegendTile :: !Text -- ^ the lit place plan legend ground name + , couterFenceTile :: !Text -- ^ the outer fence wall group name + , clegendDarkTile :: !Text -- ^ the dark place plan legend group name + , clegendLitTile :: !Text -- ^ the lit place plan legend group name } deriving Show -- No Eq and Ord to make extending it logically sound, see #53 @@ -45,18 +45,21 @@ -- -- Catch caves with not enough space for all the places. Check the size -- of the cave descriptions to make sure they fit on screen. -cvalidate :: [CaveKind] -> [CaveKind] -cvalidate = L.filter (\ CaveKind{ cgrid - , cminPlaceSize - , cmaxPlaceSize - , .. - } -> +validateCaveKind :: [CaveKind] -> [CaveKind] +validateCaveKind = filter (\ CaveKind{..} -> let (maxGridX, maxGridY) = maxDiceXY cgrid (minMinSizeX, minMinSizeY) = minDiceXY cminPlaceSize (maxMinSizeX, maxMinSizeY) = maxDiceXY cminPlaceSize (minMaxSizeX, minMaxSizeY) = minDiceXY cmaxPlaceSize - xborder = if maxGridX == 1 then 3 else 1 - yborder = if maxGridX == 1 then 3 else 1 + -- If there is at most one room, we need extra borders for a passage, + -- but if there may be more rooms, we have that space, anyway, + -- because multiple rooms take more space than borders. + xborder = if maxGridX == 1 || couterFenceTile /= "basic outer fence" + then 2 + else 0 + yborder = if maxGridY == 1 || couterFenceTile /= "basic outer fence" + then 2 + else 0 in T.length cname > 25 || cxsize < 7 || cysize < 7 @@ -64,5 +67,5 @@ || minMinSizeY < 1 || minMaxSizeX < maxMinSizeX || minMaxSizeY < maxMinSizeY - || maxGridX * (maxMinSizeX + xborder) >= cxsize - || maxGridY * (maxMinSizeY + yborder) >= cysize) + || maxGridX * (maxMinSizeX + 1) + xborder >= cxsize + || maxGridY * (maxMinSizeY + 1) + yborder >= cysize) diff --git a/Game/LambdaHack/Content/FactionKind.hs b/Game/LambdaHack/Content/FactionKind.hs --- a/Game/LambdaHack/Content/FactionKind.hs +++ b/Game/LambdaHack/Content/FactionKind.hs @@ -1,6 +1,6 @@ -- | The type of kinds of game factions (heroes, enemies, NPCs, etc.). module Game.LambdaHack.Content.FactionKind - ( FactionKind(..), fvalidate + ( FactionKind(..), validateFactionKind ) where import Data.Text (Text) @@ -12,12 +12,12 @@ { fsymbol :: !Char -- ^ a symbol , fname :: !Text -- ^ short description , ffreq :: !Freqs -- ^ frequency within groups - , fAbilityLeader :: ![Ability] -- ^ abilities of the selected actor + , fAbilityLeader :: ![Ability] -- ^ abilities of the picked leader , fAbilityOther :: ![Ability] -- ^ abilities of the other actors } deriving Show -- | No specific possible problems for the content of this kind, so far, -- so the validation function always returns the empty list of offending kinds. -fvalidate :: [FactionKind] -> [FactionKind] -fvalidate _ = [] +validateFactionKind :: [FactionKind] -> [FactionKind] +validateFactionKind _ = [] diff --git a/Game/LambdaHack/Content/ItemKind.hs b/Game/LambdaHack/Content/ItemKind.hs --- a/Game/LambdaHack/Content/ItemKind.hs +++ b/Game/LambdaHack/Content/ItemKind.hs @@ -1,32 +1,33 @@ -- | The type of kinds of weapons and treasure. module Game.LambdaHack.Content.ItemKind - ( ItemKind(..), ivalidate + ( ItemKind(..), validateItemKind ) where import Data.Text (Text) +import qualified Data.Text as T import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Common.Effect import Game.LambdaHack.Common.Flavour +import qualified Game.LambdaHack.Common.ItemFeature as IF import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Random -- | Item properties that are fixed for a given kind of items. data ItemKind = ItemKind - { isymbol :: !Char -- ^ map symbol - , iname :: !Text -- ^ generic name - , ifreq :: !Freqs -- ^ frequency within groups - , iflavour :: ![Flavour] -- ^ possible flavours - , ieffect :: !(Effect RollDeep) -- ^ the effect when activated - , icount :: !RollDeep -- ^ created in that quantify - , iverbApply :: !MU.Part -- ^ the verb for applying and combat - , iverbProject :: !MU.Part -- ^ the verb for projecting - , iweight :: !Int -- ^ weight in grams - , itoThrow :: !Int -- ^ percentage bonus or malus to throw speed + { isymbol :: !Char -- ^ map symbol + , iname :: !Text -- ^ generic name + , ifreq :: !Freqs -- ^ frequency within groups + , iflavour :: ![Flavour] -- ^ possible flavours + , icount :: !RollDeep -- ^ created in that quantify + , iverbApply :: !MU.Part -- ^ the verb for applying and combat + , iverbProject :: !MU.Part -- ^ the verb for projecting + , iweight :: !Int -- ^ weight in grams + , itoThrow :: !Int -- ^ percentage bonus to throw speed + , ifeature :: ![IF.Feature] -- ^ properties } deriving Show -- No Eq and Ord to make extending it logically sound, see #53 -- | No specific possible problems for the content of this kind, so far, -- so the validation function always returns the empty list of offending kinds. -ivalidate :: [ItemKind] -> [ItemKind] -ivalidate _ = [] +validateItemKind :: [ItemKind] -> [ItemKind] +validateItemKind l = filter (\ik -> T.length (iname ik) > 25) l diff --git a/Game/LambdaHack/Content/ModeKind.hs b/Game/LambdaHack/Content/ModeKind.hs --- a/Game/LambdaHack/Content/ModeKind.hs +++ b/Game/LambdaHack/Content/ModeKind.hs @@ -1,12 +1,12 @@ -- | The type of kinds of game modes. module Game.LambdaHack.Content.ModeKind - ( Caves, Players(..), Player(..), ModeKind(..), mvalidate + ( Caves, Players(..), Player(..), ModeKind(..), validateModeKind ) where import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Text (Text) -import NLP.Miniutter.English () +import qualified NLP.Miniutter.English as MU () import Game.LambdaHack.Common.Misc (Freqs, LevelId) @@ -39,6 +39,7 @@ data Player = Player { playerName :: !Text -- ^ name of the player , playerFaction :: !Text -- ^ name of faction(s) the player can control + , playerSpawn :: !Int -- ^ spawning frequency , playerEntry :: !LevelId -- ^ level where the initial members start , playerInitial :: !Int -- ^ number of initial members , playerAiLeader :: !Bool -- ^ is the leader under AI control? @@ -50,17 +51,19 @@ } deriving (Show, Eq) +-- TODO: assert every Player's playerName's first word's length <= 15 -- TODO: assert if no UI, both Ai are on and there are some non-spawners; -- assert that playersEnemy and playersAlly mention only factions in play. -- | No specific possible problems for the content of this kind, so far, -- so the validation function always returns the empty list of offending kinds. -mvalidate :: [ModeKind] -> [ModeKind] -mvalidate _ = [] +validateModeKind :: [ModeKind] -> [ModeKind] +validateModeKind _ = [] instance Binary Player where put Player{..} = do put playerName put playerFaction + put playerSpawn put playerEntry put playerInitial put playerAiLeader @@ -70,10 +73,11 @@ get = do playerName <- get playerFaction <- get + playerSpawn <- get playerEntry <- get playerInitial <- get playerAiLeader <- get playerAiOther <- get playerHuman <- get playerUI <- get - return Player{..} + return $! Player{..} diff --git a/Game/LambdaHack/Content/PlaceKind.hs b/Game/LambdaHack/Content/PlaceKind.hs --- a/Game/LambdaHack/Content/PlaceKind.hs +++ b/Game/LambdaHack/Content/PlaceKind.hs @@ -1,9 +1,8 @@ -- | The type of kinds of rooms, halls and passages. module Game.LambdaHack.Content.PlaceKind - ( PlaceKind(..), Cover(..), Fence(..), pvalidate + ( PlaceKind(..), Cover(..), Fence(..), validatePlaceKind ) where -import qualified Data.List as L import Data.Text (Text) import qualified Data.Text as T @@ -43,9 +42,9 @@ -- | Filter a list of kinds, passing through only the incorrect ones, if any. -- -- Verify that the top-left corner map is rectangular and not empty. -pvalidate :: [PlaceKind] -> [PlaceKind] -pvalidate = L.filter (\ PlaceKind{..} -> +validatePlaceKind :: [PlaceKind] -> [PlaceKind] +validatePlaceKind = filter (\ PlaceKind{..} -> let dxcorner = case ptopLeft of [] -> 0 l : _ -> T.length l - in dxcorner /= 0 && L.any (/= dxcorner) (L.map T.length ptopLeft)) + in dxcorner /= 0 && any (/= dxcorner) (map T.length ptopLeft)) diff --git a/Game/LambdaHack/Content/RuleKind.hs b/Game/LambdaHack/Content/RuleKind.hs --- a/Game/LambdaHack/Content/RuleKind.hs +++ b/Game/LambdaHack/Content/RuleKind.hs @@ -1,17 +1,21 @@ -- | The type of game rule sets and assorted game data. module Game.LambdaHack.Content.RuleKind - ( RuleKind(..), ruvalidate + ( RuleKind(..), validateRuleKind, FovMode(..) ) where +import Data.Binary import Data.Text (Text) import Data.Version +import Game.LambdaHack.Common.HumanCmd +import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.PointXY -import Game.LambdaHack.Content.TileKind -- TODO: very few rules are configurable yet, extend as needed. +-- TODO: in the future, in @raccessible@ check flying for chasms, +-- swimming for water, etc. +-- TODO: tweak other code to allow games with only cardinal direction moves -- | The type of game rule sets and assorted game data. -- @@ -23,25 +27,64 @@ -- and then @RuleKind@ will become just a starting template, analogously -- as for the other content. -- --- The @raccessible@ field holds a predicate that tells --- whether one position is accessible from another. +-- The @raccessible@ field hold extra conditions that have to be met +-- for a tile to be accessible, on top of being an open tile +-- (or openable, in some contexts). The @raccessibleDoor@ field +-- contains yet additional conditions concerning tiles that are doors, +-- whether open or closed. -- Precondition: the two positions are next to each other. +-- We assume the predicate is symmetric. data RuleKind = RuleKind - { rsymbol :: !Char -- ^ a symbol - , rname :: !Text -- ^ short description - , rfreq :: !Freqs -- ^ frequency within groups - , raccessible :: X -> Point -> TileKind -> Point -> TileKind -> Bool - , rtitle :: !Text -- ^ the title of the game - , rpathsDataFile :: FilePath -> IO FilePath -- ^ the path to data files - , rpathsVersion :: !Version -- ^ the version of the game - , ritemMelee :: ![Char] -- ^ symbols of melee weapons - , ritemRanged :: ![Char] -- ^ symbols of ranged weapons and missiles - , ritemProject :: ![Char] -- ^ symbols of items AI can project - , rcfgRulesDefault :: !String -- ^ the default game rules config file - , rcfgUIDefault :: !String -- ^ the default UI settings config file - , rmainMenuArt :: !Text -- ^ the ASCII art for the Main Menu + { rsymbol :: !Char -- ^ a symbol + , rname :: !Text -- ^ short description + , rfreq :: !Freqs -- ^ frequency within groups + , raccessible :: !(Maybe (Point -> Point -> Bool)) + , raccessibleDoor :: !(Maybe (Point -> Point -> Bool)) + , rtitle :: !Text -- ^ the title of the game + , rpathsDataFile :: FilePath -> IO FilePath + -- ^ the path to data files + , rpathsVersion :: !Version -- ^ the version of the game + , ritemMelee :: ![Char] -- ^ symbols of melee weapons + , ritemRanged :: ![Char] -- ^ ranged weapons and missiles + , ritemProject :: ![Char] -- ^ symbols of items AI can project + , rcfgUIName :: !FilePath -- ^ base name of the UI config file + , rcfgUIDefault :: !String -- ^ the default UI settings config file + , rmainMenuArt :: !Text -- ^ the ASCII art for the Main Menu + , rhumanCommands :: ![(K.KM, (CmdCategory, HumanCmd))] + -- ^ default client commands + , rfirstDeathEnds :: !Bool -- ^ whether first non-spawner actor death + -- ends the game + , rfovMode :: !FovMode -- ^ FOV calculation mode + , rsaveBkpClips :: !Int -- ^ game backup is saved that often + , rleadLevelClips :: !Int -- ^ AI/spawn leader level flipped that often + , rscoresFile :: !FilePath -- ^ name of the scores file + , rsavePrefix :: !String -- ^ name of the savefile prefix } +-- TODO: should Blind really be a FovMode, or a modifier? Let's decide +-- when other similar modifiers are added. +-- | Field Of View scanning mode. +data FovMode = + Shadow -- ^ restrictive shadow casting + | Permissive -- ^ permissive FOV + | Digital !Int -- ^ digital FOV with the given radius + | Blind -- ^ only feeling out adjacent tiles by touch + deriving (Show, Read) + +instance Binary FovMode where + put Shadow = putWord8 0 + put Permissive = putWord8 1 + put (Digital r) = putWord8 2 >> put r + put Blind = putWord8 3 + get = do + tag <- getWord8 + case tag of + 0 -> return Shadow + 1 -> return Permissive + 2 -> fmap Digital get + 3 -> return Blind + _ -> fail "no parse (FovMode)" + -- | A dummy instance of the 'Show' class, to satisfy general requirments -- about content. We won't have many rule sets and they contain functions, -- so defining a proper instance is not practical. @@ -49,5 +92,5 @@ show _ = "The game ruleset specification." -- | Validates the ASCII art format (TODO). -ruvalidate :: [RuleKind] -> [RuleKind] -ruvalidate _ = [] +validateRuleKind :: [RuleKind] -> [RuleKind] +validateRuleKind _ = [] diff --git a/Game/LambdaHack/Content/TileKind.hs b/Game/LambdaHack/Content/TileKind.hs --- a/Game/LambdaHack/Content/TileKind.hs +++ b/Game/LambdaHack/Content/TileKind.hs @@ -1,27 +1,28 @@ -- | The type of kinds of terrain tiles. module Game.LambdaHack.Content.TileKind - ( TileKind(..), tvalidate + ( TileKind(..), validateTileKind, actionFeatures ) where -import qualified Data.List as L +import Control.Exception.Assert.Sugar import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.Set as S import Data.Text (Text) import Game.LambdaHack.Common.Color -import Game.LambdaHack.Common.Feature +import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Misc -import Control.Exception.Assert.Sugar -- | The type of kinds of terrain tiles. See @Tile.hs@ for explanation -- of the absence of a corresponding type @Tile@ that would hold -- particular concrete tiles in the dungeon. data TileKind = TileKind - { tsymbol :: !Char -- ^ map symbol - , tname :: !Text -- ^ short description - , tfreq :: !Freqs -- ^ frequency within groups - , tcolor :: !Color -- ^ map color - , tcolor2 :: !Color -- ^ map color when not in FOV - , tfeature :: ![Feature] -- ^ properties + { tsymbol :: !Char -- ^ map symbol + , tname :: !Text -- ^ short description + , tfreq :: !Freqs -- ^ frequency within groups + , tcolor :: !Color -- ^ map color + , tcolor2 :: !Color -- ^ map color when not in FOV + , tfeature :: ![F.Feature] -- ^ properties } deriving Show -- No Eq and Ord to make extending it logically sound, see #53 @@ -30,25 +31,52 @@ -- TODO: verify that OpenTo, CloseTo and ChangeTo are assigned as specified. -- | Filter a list of kinds, passing through only the incorrect ones, if any. -- --- If tiles look the same on the map, the description should be the same, too. --- Otherwise, the player has to inspect manually all the tiles of that kind --- to see if any is special. This is a part of a stronger --- but less precise property that tiles that look the same can't be --- distinguished by player actions (but may behave differently --- wrt dungeon generation, AI preferences, etc.). -tvalidate :: [TileKind] -> [TileKind] -tvalidate lt = - let listFov f = L.map (\ kt -> ( ( tsymbol kt - , Suspect `elem` tfeature kt - , f kt - ) - , [kt] )) lt +-- If tiles look the same on the map, the description and the substantial +-- features should be the same, too. Otherwise, the player has to inspect +-- manually all the tiles of that kind, or even experiment with them, +-- to see if any is special. This would be tedious. Note that iiles may freely +-- differ wrt dungeon generation, AI preferences, etc. +validateTileKind :: [TileKind] -> [TileKind] +validateTileKind lt = + let listFov f = map (\kt -> ( ( tsymbol kt + , F.Suspect `elem` tfeature kt + , f kt + ) + , [kt] )) lt mapFov :: (TileKind -> Color) -> M.Map (Char, Bool, Color) [TileKind] mapFov f = M.fromListWith (++) $ listFov f namesUnequal [] = assert `failure` "no TileKind content" `twith` lt - namesUnequal (hd : tl) = -- Check that at least one is different. - L.any (/= tname hd) (L.map tname tl) - confusions f = L.filter namesUnequal $ M.elems $ mapFov f + namesUnequal (hd : tl) = + -- Catch if at least one is different. + any (/= tname hd) (map tname tl) + || any (/= actionFeatures True hd) (map (actionFeatures True) tl) + confusions f = filter namesUnequal $ M.elems $ mapFov f in case confusions tcolor ++ confusions tcolor2 of [] -> [] l : _ -> l + +-- | Features of tiles that differentiate them substantially from one another. +-- By tile contents validation condition, this means the player +-- can tell such tile apart, and only looking at the map, not tile name. +-- So if running uses this function, it won't stop at places that the player +-- can't himself tell from other places, and so running does not confer +-- any advantages, except UI convenience. +actionFeatures :: Bool -> TileKind -> S.Set F.Feature +actionFeatures markSuspect t = + let f feat = case feat of + F.Cause{} -> Just feat + F.OpenTo{} -> Just $ F.OpenTo "" -- if needed, remove prefix/suffix + F.CloseTo{} -> Just $ F.CloseTo "" + F.ChangeTo{} -> Just $ F.ChangeTo "" + F.Walkable -> Just feat + F.Clear -> Just feat + F.Suspect -> if markSuspect then Just feat else Nothing + F.Aura{} -> Just feat + F.Impenetrable -> Just feat + F.Trail -> Just feat -- doesn't affect tile behaviour, but important + F.HideAs{} -> Nothing + F.RevealAs{} -> Nothing + F.Dark -> Nothing -- not important any longer, after FOV computed + F.CanItem -> Nothing + F.CanActor -> Nothing + in S.fromList $ mapMaybe f $ tfeature t diff --git a/Game/LambdaHack/Frontend.hs b/Game/LambdaHack/Frontend.hs --- a/Game/LambdaHack/Frontend.hs +++ b/Game/LambdaHack/Frontend.hs @@ -12,6 +12,7 @@ import Control.Concurrent import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, writeTQueue) import qualified Control.Concurrent.STM as STM +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import Data.Maybe @@ -21,7 +22,6 @@ import System.IO import System.IO.Unsafe (unsafePerformIO) -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Animation import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Key as K @@ -59,7 +59,9 @@ startupF :: DebugModeCli -> IO () -> IO () startupF dbg cont = - (if sfrontendStd dbg then stdStartup else chosenStartup) dbg $ \fs -> do + (if sfrontendNo dbg then noStartup + else if sfrontendStd dbg then stdStartup + else chosenStartup) dbg $ \fs -> do let debugPrint t = when (sdbgMsgCli dbg) $ do T.hPutStrLn stderr t hFlush stderr @@ -80,7 +82,7 @@ promptGetKey fs keys@(firstKM:_) frame = do km <- fpromptGetKey fs frame if km `elem` keys - then return km + then return $! km else do let DebugModeCli{snoMore} = fdebugCli fs if snoMore then return firstKM @@ -92,7 +94,7 @@ connMulti = unsafePerformIO $ do fromMulti <- newMVar undefined toMulti <- newTQueueIO - return ConnMulti{..} + return $! ConnMulti{..} -- | Augment a function that takes and returns keys. getConfirmGeneric :: Monad m @@ -109,7 +111,7 @@ let queue = toListLQueue $ fromMaybe newLQueue $ EM.lookup fid reqMap reqMap2 = EM.delete fid reqMap mapM_ (displayAc fs) queue - return reqMap2 + return $! reqMap2 displayAc :: Frontend -> AcFrame -> IO () displayAc fs (AcConfirm fr) = void $ getConfirmGeneric (promptGetKey fs) [] fr @@ -133,12 +135,12 @@ let topRight = True lxsize = xsizeSingleFrame frame lysize = ysizeSingleFrame frame - msg = "Player" <+> showT (fromEnum side) <> "," + msg = "Player" <+> tshow (fromEnum side) <> "," <+> pname <> (if T.null pname then "" else ",") <+> "get ready!" animMap <- rndToIO $ fadeout out topRight lxsize lysize - let sfTop = truncateMsg lxsize msg - basicFrame = frame {sfTop} + let sfTop = truncateToOverlay lxsize msg + basicFrame = frame {sfTop} -- overwrite the whole original overlay animFrs = renderAnim lxsize lysize basicFrame animMap frs | out = animFrs -- Empty frame to mark the fade-in end, @@ -182,7 +184,7 @@ let singles = toSingles oldFid reqMap -- not @reqMap2@! lastFrame = fromMaybe oldFrame $ listToMaybe $ reverse singles fadeF fs True fid pname lastFrame - return reqMap2 + return $! reqMap2 let singles = toSingles fid reqMap2 firstFrame = fromMaybe frontFr $ listToMaybe singles -- TODO: @nU@ is unreliable, when some of UI players die; diff --git a/Game/LambdaHack/Frontend/Chosen.hs b/Game/LambdaHack/Frontend/Chosen.hs --- a/Game/LambdaHack/Frontend/Chosen.hs +++ b/Game/LambdaHack/Frontend/Chosen.hs @@ -2,7 +2,7 @@ -- | Re-export the operations of the chosen raw frontend -- (determined at compile time with cabal flags). module Game.LambdaHack.Frontend.Chosen - ( Frontend(..), chosenStartup, stdStartup + ( Frontend(..), chosenStartup, stdStartup, noStartup , frontendName ) where @@ -44,5 +44,13 @@ cont $ Frontend { fdisplay = Std.fdisplay fs , fpromptGetKey = Std.fpromptGetKey fs + , fdebugCli + } + +noStartup :: DebugModeCli -> (Frontend -> IO ()) -> IO () +noStartup fdebugCli cont = + cont $ Frontend + { fdisplay = \_ _ -> return () + , fpromptGetKey = \_ -> return K.escKey , fdebugCli } diff --git a/Game/LambdaHack/Frontend/Curses.hs b/Game/LambdaHack/Frontend/Curses.hs --- a/Game/LambdaHack/Frontend/Curses.hs +++ b/Game/LambdaHack/Frontend/Curses.hs @@ -1,4 +1,6 @@ --- | Text frontend based on HSCurses. +-- | Text frontend based on HSCurses. This frontend is not fully supported +-- due to the limitations of the curses library (keys, colours, last character +-- of the last line). module Game.LambdaHack.Frontend.Curses ( -- * Session data type for the frontend FrontendSession @@ -8,16 +10,15 @@ , frontendName, startup ) where +import Control.Exception.Assert.Sugar import Control.Monad import Data.Char (chr, ord) -import qualified Data.List as L import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified UI.HSCurses.Curses as C import qualified UI.HSCurses.CursesHelper as C -import Control.Exception.Assert.Sugar -import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..)) +import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Common.Msg @@ -45,7 +46,7 @@ -- No more color combinations possible: 16*4, 64 is max. bg <- Color.legalBG ] nr <- C.colorPairs - when (nr < L.length s) $ + when (nr < length s) $ C.end >> (assert `failure` "terminal has too few color pairs" `twith` nr) let (ks, vs) = unzip s ws <- C.convertStyles vs @@ -60,18 +61,19 @@ -> Maybe SingleFrame -- ^ the screen frame to draw -> IO () fdisplay _ _ Nothing = return () -fdisplay FrontendSession{..} _ (Just SingleFrame{..}) = do +fdisplay FrontendSession{..} _ (Just rawSF) = do + let SingleFrame{sfLevel} = overlayOverlay rawSF -- let defaultStyle = C.defaultCursesStyle -- Terminals with white background require this: let defaultStyle = sstyles M.! Color.defAttr C.erase C.setStyle defaultStyle - C.mvWAddStr swin 0 0 (T.unpack sfTop) -- We need to remove the last character from the status line, -- because otherwise it would overflow a standard size xterm window, -- due to the curses historical limitations. - C.mvWAddStr swin (L.length sfLevel + 1) 0 (L.init $ T.unpack sfBottom) - let nm = L.zip [0..] $ L.map (L.zip [0..]) sfLevel + let sfLevelDecoded = map decodeLine sfLevel + level = init sfLevelDecoded ++ [init $ last sfLevelDecoded] + nm = zip [0..] $ map (zip [0..]) level sequence_ [ C.setStyle (M.findWithDefault defaultStyle acAttr sstyles) >> C.mvWAddStr swin (y + 1) x [acChar] | (y, line) <- nm, (x, Color.AttrChar{..}) <- line ] @@ -100,6 +102,7 @@ C.KeyChar ' ' -> (K.Space, K.NoModifier) C.KeyChar '\t' -> (K.Tab, K.NoModifier) C.KeyBTab -> (K.BackTab, K.NoModifier) + C.KeyBackspace -> (K.BackSpace, K.NoModifier) C.KeyUp -> (K.Up, K.NoModifier) C.KeyDown -> (K.Down, K.NoModifier) C.KeyLeft -> (K.Left, K.NoModifier) @@ -107,8 +110,8 @@ C.KeyRight -> (K.Right, K.NoModifier) C.KeySRight -> (K.Right, K.NoModifier) C.KeyHome -> (K.Home, K.NoModifier) - C.KeyPPage -> (K.PgUp, K.NoModifier) C.KeyEnd -> (K.End, K.NoModifier) + C.KeyPPage -> (K.PgUp, K.NoModifier) C.KeyNPage -> (K.PgDn, K.NoModifier) C.KeyBeg -> (K.Begin, K.NoModifier) C.KeyB2 -> (K.Begin, K.NoModifier) @@ -122,12 +125,12 @@ | ord '\^A' <= ord c && ord c <= ord '\^Z' -> -- Alas, only lower-case letters. (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control) - -- Movement keys are more important than hero selection, + -- Movement keys are more important than leader picking, -- so disabling the latter and interpreting the keypad numbers -- as movement: | c `elem` ['1'..'9'] -> (K.KP c, K.NoModifier) | otherwise -> (K.Char c, K.NoModifier) - _ -> (K.Unknown (showT e), K.NoModifier) + _ -> (K.Unknown (tshow e), K.NoModifier) toFColor :: Color.Color -> C.ForegroundColor toFColor Color.Black = C.BlackF diff --git a/Game/LambdaHack/Frontend/Gtk.hs b/Game/LambdaHack/Frontend/Gtk.hs --- a/Game/LambdaHack/Frontend/Gtk.hs +++ b/Game/LambdaHack/Frontend/Gtk.hs @@ -10,6 +10,7 @@ ) where import Control.Concurrent +import Control.Exception.Assert.Sugar import Control.Monad import Control.Monad.Reader import qualified Data.ByteString.Char8 as BS @@ -17,13 +18,10 @@ import Data.List import qualified Data.Map.Strict as M import Data.Maybe -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) import Graphics.UI.Gtk hiding (Point) import System.Time -import Control.Exception.Assert.Sugar -import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..)) +import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Utils.LQueue @@ -75,13 +73,6 @@ _ -> putMVar sframeState fs -lengthQueue :: FrontendSession -> IO Int -lengthQueue FrontendSession{sframeState} = do - fs <- readMVar sframeState - case fs of - FPushed{..} -> return $ lengthLQueue fpushed - _ -> return 0 - -- | The name of the frontend. frontendName :: String frontendName = "gtk" @@ -135,20 +126,9 @@ let !key = K.keyTranslate n !modifier = modifierTranslate mods liftIO $ do - unless (deadKey n) $ do - len <- lengthQueue sess - if n == "space" && len > 1 then - -- Only drop frames up to the first empty frame. - -- Some new frames may be arriving at the same time - -- or being displayed and removed, but we don't care. - onQueue dropStartLQueue sess - else - -- Store the key in the channel. All but last frame will be dropped - -- as soon as the channel is read. Use SPACE repeatedly to step - -- through some intermediate frames of an animation --- other keys - -- are not meant to be pressed many times before the engine - -- is ready to recognize and process them. - writeChan schanKey K.KM {key, modifier} + unless (deadKey n) $ + -- Store the key in the channel. + writeChan schanKey K.KM{key, modifier} return True -- Set the font specified in config, if any. f <- fontDescriptionFromString $ fromMaybe "" sfont @@ -202,7 +182,7 @@ setTo :: TextBuffer -> TextTag -> Int -> (Int, [TextTag]) -> IO () setTo _ _ _ (_, []) = return () setTo tb defAttr lx (ly, attr:attrs) = do - ib <- textBufferGetIterAtLineOffset tb (ly + 1) lx + ib <- textBufferGetIterAtLineOffset tb ly lx ie <- textIterCopy ib let setIter :: TextTag -> Int -> [TextTag] -> IO () setIter previous repetitions [] = do @@ -250,8 +230,8 @@ -- Check if the time is up. let maxFps = fromMaybe defaultMaxFps smaxFps curTime <- getClockTime - let diffT = diffTime setTime curTime - if diffT > microInSec `div` maxPolls maxFps + let diffSetCur = diffTime setTime curTime + if diffSetCur > microInSec `div` maxPolls maxFps then do -- Delay half of the time difference. threadDelay $ diffTime curTime setTime `div` 2 @@ -344,12 +324,13 @@ Just f -> putMVar slastFull (f, noDelay) evalFrame :: FrontendSession -> SingleFrame -> GtkFrame -evalFrame FrontendSession{stags} SingleFrame{..} = - let levelChar = map (T.pack . map Color.acChar) sfLevel - gfChar = encodeUtf8 $ T.intercalate (T.singleton '\n') - $ sfTop : levelChar ++ [sfBottom] - -- Strict version of @map (map ((stags M.!) . fst)) sfLevel@. - gfAttr = reverse $ foldl' ff [] sfLevel +evalFrame FrontendSession{stags} rawSF = + let SingleFrame{sfLevel} = overlayOverlay rawSF + sfLevelDecoded = map decodeLine sfLevel + levelChar = unlines $ map (map Color.acChar) sfLevelDecoded + gfChar = BS.pack $ init levelChar + -- Strict version of @map (map ((stags M.!) . fst)) sfLevelDecoded@. + gfAttr = reverse $ foldl' ff [] sfLevelDecoded ff ll l = reverse (foldl' f [] l) : ll f l ac = let !tag = stags M.! Color.acAttr ac in tag : l in GtkFrame{..} @@ -411,22 +392,31 @@ return () -- | Display a prompt, wait for any key. --- Starts in Push mode, ends in None mode. +-- Starts in Push mode, ends in Push or None mode. -- Syncs with the drawing threads by showing the last or all queued frames. fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM fpromptGetKey sess@FrontendSession{sdebugCli=DebugModeCli{snoMore}, ..} frame = do pushFrame sess True True $ Just frame if snoMore then do - -- Show all frames synchronously. + -- Show all frames synchronously. Keys completely ignored. TODO: K.Space fs <- takeMVar sframeState displayAllFramesSync sess fs putMVar sframeState FNone return K.escKey else do km <- readChan schanKey - -- Show the last frame and empty the queue. - trimFrameState sess + case km of + K.KM{key=K.Space, modifier=K.NoModifier} -> + -- Drop frames up to the first empty frame. + -- Keep the last non-empty frame, if any. + -- Pressing SPACE repeatedly can be used to step + -- through intermediate stages of an animation, + -- whereas any other key skips the whole animation outright. + onQueue dropStartLQueue sess + _ -> + -- Show the last non-empty frame and empty the queue. + trimFrameState sess return km -- | Tells a dead key. diff --git a/Game/LambdaHack/Frontend/Std.hs b/Game/LambdaHack/Frontend/Std.hs --- a/Game/LambdaHack/Frontend/Std.hs +++ b/Game/LambdaHack/Frontend/Std.hs @@ -10,11 +10,9 @@ import qualified Data.ByteString.Char8 as BS import Data.Char (chr, ord) -import qualified Data.List as L -import Data.Text.Encoding (encodeUtf8) import qualified System.IO as SIO -import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..)) +import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Key as K @@ -37,9 +35,9 @@ -> Maybe SingleFrame -- ^ the screen frame to draw -> IO () fdisplay _ _ Nothing = return () -fdisplay _ _ (Just SingleFrame{..}) = - let chars = L.map (BS.pack . L.map Color.acChar) sfLevel - bs = [encodeUtf8 sfTop, BS.empty] ++ chars ++ [encodeUtf8 sfBottom, BS.empty] +fdisplay _ _ (Just rawSF) = + let SingleFrame{sfLevel} = overlayOverlay rawSF + bs = map (BS.pack . map Color.acChar . decodeLine) sfLevel ++ [BS.empty] in mapM_ BS.putStrLn bs -- | Input key via the frontend. @@ -70,7 +68,7 @@ c | ord '\^A' <= ord c && ord c <= ord '\^Z' -> -- Alas, only lower-case letters. (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control) - -- Movement keys are more important than hero selection, + -- Movement keys are more important than leader picking, -- so disabling the latter and interpreting the keypad numbers -- as movement: | c `elem` ['1'..'9'] -> (K.KP c, K.NoModifier) diff --git a/Game/LambdaHack/Frontend/Vty.hs b/Game/LambdaHack/Frontend/Vty.hs --- a/Game/LambdaHack/Frontend/Vty.hs +++ b/Game/LambdaHack/Frontend/Vty.hs @@ -8,12 +8,10 @@ , frontendName, startup ) where -import qualified Data.List as L -import Data.Text.Encoding (encodeUtf8) import Graphics.Vty import qualified Graphics.Vty as Vty -import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..)) +import Game.LambdaHack.Common.Animation import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Common.Msg @@ -42,16 +40,14 @@ -> Maybe SingleFrame -- ^ the screen frame to draw -> IO () fdisplay _ _ Nothing = return () -fdisplay FrontendSession{svty} _ (Just SingleFrame{..}) = - let img = (foldr (<->) empty_image - . L.map (foldr (<|>) empty_image - . L.map (\ Color.AttrChar{..} -> +fdisplay FrontendSession{svty} _ (Just rawSF) = + let SingleFrame{sfLevel} = overlayOverlay rawSF + img = (foldr (<->) empty_image + . map (foldr (<|>) empty_image + . map (\ Color.AttrChar{..} -> char (setAttr acAttr) acChar))) - sfLevel - pic = pic_for_image $ - utf8_bytestring (setAttr Color.defAttr) (encodeUtf8 sfTop) - <-> img <-> - utf8_bytestring (setAttr Color.defAttr) (encodeUtf8 sfBottom) + $ map decodeLine sfLevel + pic = pic_for_image img in update svty pic -- | Input key via the frontend. @@ -64,7 +60,7 @@ EvKey n mods -> do let key = keyTranslate n modifier = modifierTranslate mods - return K.KM {key, modifier} + return $! K.KM {key, modifier} _ -> nextEvent sess -- | Display a prompt, wait for any key. @@ -73,6 +69,9 @@ fdisplay sess True $ Just frame nextEvent sess +-- TODO: Ctrl-Home and Ctrl-End are the same as Home and End on some terminals +-- so we should probably go back to using 0-9 (and Shift) for movement +-- but let's wait until vty 5.0 is out and see if it helps. keyTranslate :: Key -> K.Key keyTranslate n = case n of @@ -81,23 +80,26 @@ (KASCII ' ') -> K.Space (KASCII '\t') -> K.Tab KBackTab -> K.BackTab + KBS -> K.BackSpace KUp -> K.Up KDown -> K.Down KLeft -> K.Left KRight -> K.Right KHome -> K.Home - KPageUp -> K.PgUp KEnd -> K.End + KPageUp -> K.PgUp KPageDown -> K.PgDn KBegin -> K.Begin + KNP5 -> K.Begin (KASCII c) -> K.Char c - _ -> K.Unknown (showT n) + _ -> K.Unknown (tshow n) -- | Translates modifiers to our own encoding. modifierTranslate :: [Modifier] -> K.Modifier modifierTranslate mods = if MCtrl `elem` mods then K.Control else K.NoModifier +-- TODO: with vty 5.0 check if bold is still needed. -- A hack to get bright colors via the bold attribute. Depending on terminal -- settings this is needed or not and the characters really get bold or not. -- HSCurses does this by default, but in Vty you have to request the hack. diff --git a/Game/LambdaHack/Server.hs b/Game/LambdaHack/Server.hs --- a/Game/LambdaHack/Server.hs +++ b/Game/LambdaHack/Server.hs @@ -16,9 +16,9 @@ import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.ServerCmd +import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Frontend import Game.LambdaHack.Server.Action -import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.LoopAction import Game.LambdaHack.Server.ServerSem import Game.LambdaHack.Server.State @@ -28,49 +28,54 @@ -- indicates if the command took some time. cmdSerSem :: (MonadAtomic m, MonadServer m) => CmdSer -> m Bool cmdSerSem cmd = case cmd of - TakeTimeSer cmd2 -> cmdSerSemTakeTime cmd2 >> return True - GameRestartSer aid t -> gameRestartSer aid t >> return False - GameExitSer aid -> gameExitSer aid >> return False + CmdTakeTimeSer cmd2 -> cmdSerSemTakeTime cmd2 >> return True + GameRestartSer aid t d names -> gameRestartSer aid t d names >> return False + GameExitSer aid d -> gameExitSer aid d >> return False GameSaveSer _ -> gameSaveSer >> return False -cmdSerSemTakeTime :: (MonadAtomic m, MonadServer m) => CmdSerTakeTime -> m () +cmdSerSemTakeTime :: (MonadAtomic m, MonadServer m) => CmdTakeTimeSer -> m () cmdSerSemTakeTime cmd = case cmd of MoveSer source target -> moveSer source target MeleeSer source target -> meleeSer source target DisplaceSer source target -> displaceSer source target AlterSer source tpos mfeat -> alterSer source tpos mfeat WaitSer aid -> waitSer aid - PickupSer aid i k l -> pickupSer aid i k l - DropSer aid iid -> dropSer aid iid + PickupSer aid i k -> pickupSer aid i k + DropSer aid iid k -> dropSer aid iid k ProjectSer aid p eps iid container -> projectSer aid p eps iid container ApplySer aid iid container -> applySer aid iid container TriggerSer aid mfeat -> triggerSer aid mfeat - SetPathSer aid path -> setPathSer aid path + SetTrajectorySer aid -> setTrajectorySer aid debugArgs :: IO DebugModeSer debugArgs = do args <- getArgs let usage = [ "Configure debug options here, gameplay options in config.rules.ini." - , " --knowMap reveal map for all clients in the next game" - , " --knowEvents show all events in the next game (needs --knowMap)" - , " --sniffIn display all incoming commands on console " - , " --sniffOut display all outgoing commands on console " - , " --allClear let all map tiles be translucent" - , " --gameMode m start next game in the given mode" - , " --newGame start a new game, overwriting the save file" - , " --stopAfter n exit this game session after around n seconds" - , " --dumpConfig dump server config at the start of the game" - , " --dbgMsgSer let the server emit its internal debug messages" - , " --font fn use the given font for the main game window" - , " --maxFps n display at most n frames per second" - , " --noDelay don't maintain any requested delays between frames" - , " --noMore auto-answer all prompts" - , " --noAnim don't show any animations" - , " --savePrefix prepend the text to all savefile names" - , " --frontendStd use the simple stdout/stdin frontend" - , " --dbgMsgCli let clients emit their internal debug messages" - , " --fovMode m set a Field of View mode, where m can be" + , " --knowMap reveal map for all clients in the next game" + , " --knowEvents show all events in the next game (needs --knowMap)" + , " --sniffIn display all incoming commands on console " + , " --sniffOut display all outgoing commands on console " + , " --allClear let all map tiles be translucent" + , " --gameMode m start next game in the given mode" + , " --newGame start a new game, overwriting the save file" + , " --difficulty n set difficulty for all UI players to n" + , " --stopAfter n exit this game session after around n seconds" + , " --benchmark print stats, limit saving and other file operations" + , " --setDungeonRng s set dungeon generation RNG seed to string s" + , " --setMainRng s set the main game RNG seed to string s" + , " --dumpInitRngs dump RNG states from the start of the game" + , " --dbgMsgSer let the server emit its internal debug messages" + , " --font fn use the given font for the main game window" + , " --maxFps n display at most n frames per second" + , " --noDelay don't maintain any requested delays between frames" + , " --noMore auto-answer all prompts" + , " --noAnim don't show any animations" + , " --savePrefix prepend the text to all savefile names" + , " --frontendStd use the simple stdout/stdin frontend" + , " --frontendNo use no frontend at all (for AIvsAI benchmarks)" + , " --dbgMsgCli let clients emit their internal debug messages" + , " --fovMode m set a Field of View mode, where m can be" , " Digital r, r > 0" , " Permissive" , " Shadow" @@ -92,12 +97,22 @@ parseArgs ("--newGame" : rest) = let debugSer = parseArgs rest in debugSer { snewGameSer = True - , sdebugCli = - (sdebugCli debugSer) {snewGameCli = True}} + , sdebugCli = (sdebugCli debugSer) {snewGameCli = True}} + parseArgs ("--difficulty" : s : rest) = + let debugSer = parseArgs rest + diff = 5 - read s + in debugSer { sdifficultySer = diff + , sdebugCli = (sdebugCli debugSer) {sdifficultyCli = diff}} parseArgs ("--stopAfter" : s : rest) = (parseArgs rest) {sstopAfter = Just $ read s} - parseArgs ("--dumpConfig" : rest) = - (parseArgs rest) {sdumpConfig = True} + parseArgs ("--benchmark" : rest) = + (parseArgs rest) {sbenchmark = True} + parseArgs ("--setDungeonRng" : s : rest) = + (parseArgs rest) {sdungeonRng = Just $ read s} + parseArgs ("--setMainRng" : s : rest) = + (parseArgs rest) {smainRng = Just $ read s} + parseArgs ("--dumpInitRngs" : rest) = + (parseArgs rest) {sdumpInitRngs = True} parseArgs ("--fovMode" : "Digital" : r : rest) | (read r :: Int) > 0 = (parseArgs rest) {sfovMode = Just $ Digital $ read r} parseArgs ("--fovMode" : mode : rest) = @@ -124,10 +139,13 @@ let debugSer = parseArgs rest in debugSer { ssavePrefixSer = Just s , sdebugCli = - (sdebugCli debugSer) {ssavePrefixCli = Just s}} + (sdebugCli debugSer) {ssavePrefixCli = Just s}} parseArgs ("--frontendStd" : rest) = let debugSer = parseArgs rest in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendStd = True}} + parseArgs ("--frontendNo" : rest) = + let debugSer = parseArgs rest + in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendNo = True}} parseArgs ("--dbgMsgCli" : rest) = let debugSer = parseArgs rest in debugSer {sdebugCli = (sdebugCli debugSer) {sdbgMsgCli = True}} @@ -146,7 +164,7 @@ -> (Kind.COps -> DebugModeCli -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer -> IO ()) - -> (FactionId -> ChanServer CmdClientAI CmdSerTakeTime + -> (FactionId -> ChanServer CmdClientAI CmdTakeTimeSer -> IO ()) -> IO ()) -> IO ()) diff --git a/Game/LambdaHack/Server/Action.hs b/Game/LambdaHack/Server/Action.hs --- a/Game/LambdaHack/Server/Action.hs +++ b/Game/LambdaHack/Server/Action.hs @@ -11,9 +11,10 @@ , sendUpdateAI, sendQueryAI, sendPingAI , sendUpdateUI, sendQueryUI, sendPingUI -- * Assorted primitives - , debugPrint, dumpCfg - , mkConfigRules, restoreScore, revealItems, deduceQuits - , rndToAction, resetSessionStart, elapsedSessionTimeGT + , debugPrint, dumpRngs + , getSetGen, restoreScore, revealItems, deduceQuits + , rndToAction, resetSessionStart, resetGameStart, elapsedSessionTimeGT + , tellAllClipPS, tellGameClipPS , resetFidPerception, getPerFid , childrenServer ) where @@ -21,7 +22,8 @@ import Control.Concurrent import Control.Concurrent.STM (TQueue, atomically) import qualified Control.Concurrent.STM as STM -import Control.DeepSeq +import qualified Control.Exception as Ex hiding (handle) +import Control.Exception.Assert.Sugar import Control.Monad import qualified Control.Monad.State as St import qualified Data.EnumMap.Strict as EM @@ -39,29 +41,29 @@ import qualified System.Random as R import System.Time -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.AtomicCmd import Game.LambdaHack.Common.ClientCmd -import qualified Game.LambdaHack.Common.ConfigIO as ConfigIO import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.HighScore as HighScore import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.Save import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile +import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Frontend as Frontend import Game.LambdaHack.Server.Action.ActionClass -import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.State import Game.LambdaHack.Utils.File @@ -81,9 +83,9 @@ cops <- getsState scops lvl <- getLevel lid fovMode <- getsServer $ sfovMode . sdebugSer - s <- getState - let per = levelPerception cops s (fromMaybe (Digital 12) fovMode) fid lid lvl - upd = EM.adjust (EM.adjust (const per) lid) fid + per <- getsState + $ levelPerception cops (fromMaybe (Digital 12) fovMode) fid lid lvl + let upd = EM.adjust (EM.adjust (const per) lid) fid modifyServer $ \ser -> ser {sper = upd (sper ser)} getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception @@ -95,14 +97,13 @@ `twith` (lid, fid)) $ EM.lookup lid fper return $! per --- | Dumps the current game rules configuration to a file. -dumpCfg :: MonadServer m => m String -dumpCfg = do - Config{configAppDataDir, configRulesCfgFile} <- getsServer sconfig - let fn = configAppDataDir configRulesCfgFile ++ ".dump" - config <- getsServer sconfig - liftIO $ ConfigIO.dump config fn - return fn +-- | Dumps RNG states from the start of the game to a file. +dumpRngs :: MonadServer m => m () +dumpRngs = do + dataDir <- liftIO appDataDir + let fn = dataDir "rngs.dump" + rngs <- getsServer srngs + liftIO $ writeFile fn (show rngs) writeTQueueAI :: MonadConnServer m => CmdClientAI -> TQueue CmdClientAI -> m () writeTQueueAI cmd fromServer = do @@ -120,15 +121,15 @@ liftIO $ T.hPutStrLn stderr d liftIO $ atomically $ STM.writeTQueue fromServer cmd -readTQueueAI :: MonadConnServer m => TQueue CmdSerTakeTime -> m CmdSerTakeTime +readTQueueAI :: MonadConnServer m => TQueue CmdTakeTimeSer -> m CmdTakeTimeSer readTQueueAI toServer = do cmd <- liftIO $ atomically $ STM.readTQueue toServer debug <- getsServer $ sniffIn . sdebugSer when debug $ do - let aid = aidCmdSerTakeTime cmd - d <- debugAid aid "CmdSerTakeTime" cmd + let aid = aidCmdTakeTimeSer cmd + d <- debugAid aid "CmdTakeTimeSer" cmd liftIO $ T.hPutStrLn stderr d - return cmd + return $! cmd readTQueueUI :: MonadConnServer m => TQueue CmdSer -> m CmdSer readTQueueUI toServer = do @@ -138,14 +139,14 @@ let aid = aidCmdSer cmd d <- debugAid aid "CmdSer" cmd liftIO $ T.hPutStrLn stderr d - return cmd + return $! cmd sendUpdateAI :: MonadConnServer m => FactionId -> CmdClientAI -> m () sendUpdateAI fid cmd = do conn <- getsDict $ snd . (EM.! fid) writeTQueueAI cmd $ fromServer conn -sendQueryAI :: MonadConnServer m => FactionId -> ActorId -> m CmdSerTakeTime +sendQueryAI :: MonadConnServer m => FactionId -> ActorId -> m CmdTakeTimeSer sendQueryAI fid aid = do conn <- getsDict $ snd . (EM.! fid) writeTQueueAI (CmdQueryAI aid) $ fromServer conn @@ -155,9 +156,9 @@ sendPingAI fid = do conn <- getsDict $ snd . (EM.! fid) writeTQueueAI CmdPingAI $ fromServer conn - -- debugPrint $ "AI client" <+> showT fid <+> "pinged..." + -- debugPrint $ "AI client" <+> tshow fid <+> "pinged..." cmdHack <- readTQueueAI $ toServer conn - -- debugPrint $ "AI client" <+> showT fid <+> "responded." + -- debugPrint $ "AI client" <+> tshow fid <+> "responded." assert (cmdHack == WaitSer (toEnum (-1))) skip sendUpdateUI :: MonadConnServer m => FactionId -> CmdClientUI -> m () @@ -184,28 +185,41 @@ Nothing -> assert `failure` "no channel for faction" `twith` fid Just (_, conn) -> do writeTQueueUI CmdPingUI $ fromServer conn - -- debugPrint $ "UI client" <+> showT fid <+> "pinged..." + -- debugPrint $ "UI client" <+> tshow fid <+> "pinged..." cmdHack <- readTQueueUI $ toServer conn - -- debugPrint $ "UI client" <+> showT fid <+> "responded." - assert (cmdHack == TakeTimeSer (WaitSer (toEnum (-1)))) skip + -- debugPrint $ "UI client" <+> tshow fid <+> "responded." + assert (cmdHack == CmdTakeTimeSer (WaitSer (toEnum (-1)))) skip +-- TODO: refactor wrt Game.LambdaHack.Common.Save -- | Read the high scores table. Return the empty table if no file. --- Warning: when it's used, the game state --- may still be undefined, hence the config is given as an argument. -restoreScore :: MonadServer m => Config -> m HighScore.ScoreTable -restoreScore Config{configAppDataDir, configScoresFile} = do - let path = configAppDataDir configScoresFile +restoreScore :: MonadServer m => Kind.COps -> m HighScore.ScoreTable +restoreScore Kind.COps{corule} = do + let stdRuleset = Kind.stdRuleset corule + scoresFile = rscoresFile stdRuleset + dataDir <- liftIO appDataDir + let path = dataDir scoresFile configExists <- liftIO $ doesFileExist path - if not configExists - then return HighScore.empty - else liftIO $ strictDecodeEOF path + mscore <- liftIO $ do + res <- Ex.try $ + if configExists then do + s <- strictDecodeEOF path + return $ Just s + else return Nothing + let handler :: Ex.SomeException -> IO (Maybe a) + handler e = do + let msg = "High score restore failed. The error message is:" + <+> (T.unwords . T.lines) (tshow e) + delayPrint $ msg + return Nothing + either handler return res + maybe (return HighScore.empty) return mscore -- | Generate a new score, register it and save. registerScore :: MonadServer m => Status -> Maybe Actor -> FactionId -> m () registerScore status mbody fid = do + cops@Kind.COps{corule} <- getsState scops assert (maybe True ((fid ==) . bfid) mbody) skip - factionD <- getsState sfactionD - let fact = factionD EM.! fid + fact <- getsState $ (EM.! fid) . sfactionD assert (playerHuman $ gplayer fact) skip total <- case mbody of Just body -> getsState $ snd . calculateTotal body @@ -214,27 +228,70 @@ Just aid -> do b <- getsState $ getActorBody aid getsState $ snd . calculateTotal b - config@Config{configAppDataDir, configScoresFile} <- getsServer sconfig + let stdRuleset = Kind.stdRuleset corule + scoresFile = rscoresFile stdRuleset + dataDir <- liftIO appDataDir -- Re-read the table in case it's changed by a concurrent game. - table <- restoreScore config + table <- restoreScore cops time <- getsState stime date <- liftIO getClockTime - let path = configAppDataDir configScoresFile + DebugModeSer{sdifficultySer} <- getsServer sdebugSer + let path = dataDir scoresFile saveScore (ntable, _) = liftIO $ encodeEOF path (ntable :: HighScore.ScoreTable) - maybe skip saveScore $ HighScore.register table total time status date + diff | not $ playerUI $ gplayer fact = 0 + | otherwise = sdifficultySer + maybe skip saveScore $ HighScore.register table total time status date diff resetSessionStart :: MonadServer m => m () resetSessionStart = do sstart <- liftIO getClockTime modifyServer $ \ser -> ser {sstart} +-- TODO: all this breaks when games are loaded; we'd need to save +-- elapsed game clock time to fix this. +resetGameStart :: MonadServer m => m () +resetGameStart = do + sgstart <- liftIO getClockTime + time <- getsState stime + modifyServer $ \ser -> + ser {sgstart, sallTime = timeAdd (sallTime ser) time} + elapsedSessionTimeGT :: MonadServer m => Int -> m Bool elapsedSessionTimeGT stopAfter = do current <- liftIO getClockTime TOD s p <- getsServer sstart - return $ TOD (s + fromIntegral stopAfter) p <= current + return $! TOD (s + fromIntegral stopAfter) p <= current +tellAllClipPS :: MonadServer m => m () +tellAllClipPS = do + bench <- getsServer $ sbenchmark . sdebugSer + when bench $ do + TOD s p <- getsServer sstart + TOD sCur pCur <- liftIO getClockTime + allTime <- getsServer sallTime + gtime <- getsState stime + let time = timeAdd allTime gtime + let diff = fromIntegral sCur + fromIntegral pCur / 10e12 + - fromIntegral s - fromIntegral p / 10e12 + cps = fromIntegral (timeFit time timeClip) / diff :: Double + debugPrint $ "Session time:" <+> tshow diff <> "s." + <+> "Average clips per second:" <+> tshow cps <> "." + +tellGameClipPS :: MonadServer m => m () +tellGameClipPS = do + bench <- getsServer $ sbenchmark . sdebugSer + when bench $ do + TOD s p <- getsServer sgstart + unless (s == 0) $ do -- loaded game, don't report anything + TOD sCur pCur <- liftIO getClockTime + time <- getsState stime + let diff = fromIntegral sCur + fromIntegral pCur / 10e12 + - fromIntegral s - fromIntegral p / 10e12 + cps = fromIntegral (timeFit time timeClip) / diff :: Double + debugPrint $ "Game time:" <+> tshow diff <> "s." + <+> "Average clips per second:" <+> tshow cps <> "." + revealItems :: (MonadAtomic m, MonadServer m) => Maybe FactionId -> Maybe Actor -> m () revealItems mfid mbody = do @@ -288,22 +345,22 @@ factionD <- getsState sfactionD let assocsInGame = filter (inGame . snd) $ EM.assocs factionD keysInGame = map fst assocsInGame - assocsSpawn = filter (isSpawnFact cops . snd) assocsInGame - assocsNotSummon = filter (not . isSummonFact cops . snd) assocsInGame + assocsNotHorror = filter (not . isHorrorFact cops . snd) assocsInGame assocsUI = filter (playerUI . gplayer . snd) assocsInGame - case assocsNotSummon of + case assocsNotHorror of _ | null assocsUI -> - -- All non-UI players left in the game win. + -- Only non-UI players left in the game and they all win. mapQuitF status{stOutcome=Conquer} keysInGame [] -> - -- Only summons remain so all win, UI or human or not, allied or not. + -- Only horrors remain, so they win. mapQuitF status{stOutcome=Conquer} keysInGame - (_, fact1) : rest | null assocsSpawn && all (isAllied fact1 . fst) rest -> - -- Only one allied team remains in a no-spawners game. + (_, fact1) : rest | all (not . isAtWar fact1 . fst) rest -> + -- Nobody is at war any more, so all win. + -- TODO: check not at war with each other. mapQuitF status{stOutcome=Conquer} keysInGame _ | stOutcome status == Escape -> do - -- Otherwise, in a spawners game or a game with many teams alive, - -- only complete Victory matters. + -- Otherwise, in a game with many warring teams alive, + -- only complete Victory matters, until enough of them die. let (victors, losers) = partition (flip isAllied fid . snd) assocsInGame mapQuitF status{stOutcome=Escape} $ map fst victors mapQuitF status{stOutcome=Defeated} $ map fst losers @@ -312,18 +369,14 @@ tryRestore :: MonadServer m => Kind.COps -> DebugModeSer -> m (Maybe (State, StateServer)) tryRestore Kind.COps{corule} sdebugSer = do - let pathsDataFile = rpathsDataFile $ Kind.stdRuleset corule + let stdRuleset = Kind.stdRuleset corule + scoresFile = rscoresFile stdRuleset + pathsDataFile = rpathsDataFile stdRuleset prefix = ssavePrefixSer sdebugSer - -- A throw-away copy of rules config, to be used until the old - -- version of the config can be read from the savefile. - (Config{ configAppDataDir - , configRulesCfgFile - , configScoresFile }, _, _) <- mkConfigRules corule Nothing - let copies = - [ (configRulesCfgFile <.> ".default", configRulesCfgFile <.> ".ini") - , (configScoresFile, configScoresFile) ] + let copies = [( "GameDefinition" scoresFile + , scoresFile )] name = fromMaybe "save" prefix <.> saveName - liftIO $ Save.restoreGame name configAppDataDir copies pathsDataFile + liftIO $ Save.restoreGame name copies pathsDataFile -- Global variable for all children threads of the server. childrenServer :: MVar [MVar ()] @@ -339,7 +392,7 @@ -> ChanServer CmdClientUI CmdSer -> IO ()) -> (FactionId - -> ChanServer CmdClientAI CmdSerTakeTime + -> ChanServer CmdClientAI CmdTakeTimeSer -> IO ()) -> m () updateConn executorUI executorAI = do @@ -349,7 +402,7 @@ mkChanServer = do fromServer <- STM.newTQueueIO toServer <- STM.newTQueueIO - return ChanServer{..} + return $! ChanServer{..} mkChanFrontend :: IO Frontend.ChanFrontend mkChanFrontend = STM.newTQueueIO addConn :: FactionId -> Faction -> IO ConnServerFaction @@ -417,62 +470,13 @@ g <- getsServer srandom let (a, ng) = St.runState r g modifyServer $ \ser -> ser {srandom = ng} - return a - --- | Gets a random generator from the config or, --- if not present, generates one and updates the config with it. -getSetGen :: ConfigIO.CP -- ^ config - -> String -- ^ name of the generator - -> Maybe R.StdGen - -> IO (R.StdGen, ConfigIO.CP) -getSetGen config option mrandom = - case ConfigIO.getOption config "engine" option of - Just sg -> return (read sg, config) - Nothing -> do - -- Pick the randomly chosen generator from the IO monad (unless given) - -- and record it in the config for debugging (can be 'D'umped). - g <- case mrandom of - Just rnd -> return rnd - Nothing -> R.newStdGen - let gs = show g - c = ConfigIO.set config "engine" option gs - return (g, c) - -parseConfigRules :: FilePath -> ConfigIO.CP -> Config -parseConfigRules dataDir cp = - let configSelfString = ConfigIO.to_string cp - configFirstDeathEnds = ConfigIO.get cp "engine" "firstDeathEnds" - configFovMode = ConfigIO.get cp "engine" "fovMode" - configSaveBkpClips = ConfigIO.get cp "engine" "saveBkpClips" - configAppDataDir = dataDir - configScoresFile = ConfigIO.get cp "file" "scoresFile" - configRulesCfgFile = "config.rules" - configSavePrefix = ConfigIO.get cp "file" "savePrefix" - configHeroNames = - let toNumber (ident, name) = - case stripPrefix "HeroName_" ident of - Just n -> (read n, T.pack name) - Nothing -> assert `failure` "wrong hero name id" `twith` ident - section = ConfigIO.getItems cp "heroName" - in map toNumber section - in Config{..} + return $! a --- | Read and parse rules config file and supplement it with random seeds. --- This creates a server config file. Warning: when it's used, the game state --- may still be undefined, hence the content ops are given as an argument. -mkConfigRules :: MonadServer m - => Kind.Ops RuleKind -> Maybe R.StdGen - -> m (Config, R.StdGen, R.StdGen) -mkConfigRules corule mrandom = do - let cpRulesDefault = rcfgRulesDefault $ Kind.stdRuleset corule - dataDir <- - liftIO $ ConfigIO.appDataDir - cpRules <- - liftIO $ ConfigIO.mkConfig cpRulesDefault $ dataDir "config.rules.ini" - (dungeonGen, cp2) <- - liftIO $ getSetGen cpRules "dungeonRandomGenerator" mrandom - (startingGen, cp3) <- - liftIO $ getSetGen cp2 "startingRandomGenerator" mrandom - let conf = parseConfigRules dataDir cp3 - -- Catch syntax errors ASAP. - return $! deepseq conf (conf, dungeonGen, startingGen) +-- | Gets a random generator from the arguments or, if not present, +-- generates one. +getSetGen :: MonadServer m + => Maybe R.StdGen + -> m R.StdGen +getSetGen mrng = case mrng of + Just rnd -> return rnd + Nothing -> liftIO $ R.newStdGen diff --git a/Game/LambdaHack/Server/Action/ActionType.hs b/Game/LambdaHack/Server/Action/ActionType.hs --- a/Game/LambdaHack/Server/Action/ActionType.hs +++ b/Game/LambdaHack/Server/Action/ActionType.hs @@ -19,7 +19,6 @@ import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State import Game.LambdaHack.Server.Action.ActionClass -import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.State data SerState = SerState @@ -39,18 +38,22 @@ getsState f = ActionSer $ gets $ f . serState instance MonadAction ActionSer where - modifyState f = - ActionSer $ modify $ \serS -> serS {serState = f $ serState serS} - putState s = - ActionSer $ modify $ \serS -> serS {serState = s} + modifyState f = ActionSer $ state $ \serS -> + let newSerS = serS {serState = f $ serState serS} + in newSerS `seq` ((), newSerS) + putState s = ActionSer $ state $ \serS -> + let newSerS = serS {serState = s} + in newSerS `seq` ((), newSerS) instance MonadServer ActionSer where getServer = ActionSer $ gets serServer getsServer f = ActionSer $ gets $ f . serServer - modifyServer f = - ActionSer $ modify $ \serS -> serS {serServer = f $ serServer serS} - putServer s = - ActionSer $ modify $ \serS -> serS {serServer = s} + modifyServer f = ActionSer $ state $ \serS -> + let newSerS = serS {serServer = f $ serServer serS} + in newSerS `seq` ((), newSerS) + putServer s = ActionSer $ state $ \serS -> + let newSerS = serS {serServer = s} + in newSerS `seq` ((), newSerS) liftIO = ActionSer . IO.liftIO saveServer = ActionSer $ do s <- gets serState @@ -70,14 +73,13 @@ executorSer :: ActionSer () -> IO () executorSer m = let saveFile (_, ser) = - configAppDataDir (sconfig ser) - fromMaybe "save" (ssavePrefixSer (sdebugSer ser)) + fromMaybe "save" (ssavePrefixSer (sdebugSer ser)) <.> saveName - exe toSave = + exe serToSave = evalStateT (runActionSer m) SerState { serState = emptyState , serServer = emptyStateServer , serDict = EM.empty - , serToSave = toSave + , serToSave } in Save.wrapInSaves saveFile exe diff --git a/Game/LambdaHack/Server/AtomicSemSer.hs b/Game/LambdaHack/Server/AtomicSemSer.hs --- a/Game/LambdaHack/Server/AtomicSemSer.hs +++ b/Game/LambdaHack/Server/AtomicSemSer.hs @@ -5,6 +5,7 @@ ( atomicSendSem ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES @@ -25,7 +26,6 @@ import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Server.Action import Game.LambdaHack.Server.State -import Control.Exception.Assert.Sugar storeUndo :: MonadServer m => Atomic -> m () storeUndo _atomic = @@ -101,14 +101,12 @@ resetFidPerception fid lid perNew <- getPerFid fid lid let inPer = diffPer perNew perOld - inPA = perActor inPer outPer = diffPer perOld perNew - outPA = perActor outPer - if EM.null outPA && EM.null inPA + if nullPer outPer && nullPer inPer then anySend fid perOld perOld else do - sendA fid $ PerceptionA lid outPA inPA unless knowEvents $ do -- inconsistencies would quickly manifest + sendA fid $ PerceptionA lid outPer inPer let remember = atomicRemember lid inPer sOld seenNew = seenAtomicCli False fid perNew seenOld = seenAtomicCli False fid perOld @@ -147,8 +145,8 @@ let inFov = ES.elems $ totalVisible inPer lvl = sdungeon s EM.! lid -- Actors. - inPrio = mapMaybe (\p -> posToActor p lid s) inFov - fActor aid = SpotActorA aid (getActorBody aid s) (getActorItem aid s) + inPrio = concatMap (\p -> posToActors p lid s) inFov + fActor ((aid, b), ais) = SpotActorA aid b ais inActor = map fActor inPrio -- Items. pMaybe p = maybe Nothing (\x -> Just (p, x)) @@ -171,7 +169,6 @@ -- TODO: make floor paths from hidden tiles -- TODO: perhaps decrease secrecy as lseen, ltime or lsmell increases -- or a per-party counter increases - -- TODO: give spawning factions a bonus to searching -- Smells. inSmellFov = ES.elems $ smellVisible inPer inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl)) inSmellFov diff --git a/Game/LambdaHack/Server/Config.hs b/Game/LambdaHack/Server/Config.hs deleted file mode 100644 --- a/Game/LambdaHack/Server/Config.hs +++ /dev/null @@ -1,53 +0,0 @@ --- | Personal game configuration file type definitions. -module Game.LambdaHack.Server.Config - ( Config(..) - ) where - -import Control.DeepSeq -import Data.Binary -import Data.Text (Text) - -import Game.LambdaHack.Server.Fov - --- | Fully typed contents of the rules config file. This config --- is a part of the game server. -data Config = Config - { configSelfString :: !String - -- engine - , configFirstDeathEnds :: !Bool - , configFovMode :: !FovMode - , configSaveBkpClips :: !Int - -- files - , configAppDataDir :: !FilePath - , configScoresFile :: !FilePath - , configRulesCfgFile :: !FilePath - , configSavePrefix :: !String - -- heroNames - , configHeroNames :: ![(Int, Text)] - } - deriving Show - -instance NFData Config - -instance Binary Config where - put Config{..} = do - put configSelfString - put configFirstDeathEnds - put configFovMode - put configSaveBkpClips - put configAppDataDir - put configScoresFile - put configRulesCfgFile - put configSavePrefix - put configHeroNames - get = do - configSelfString <- get - configFirstDeathEnds <- get - configFovMode <- get - configSaveBkpClips <- get - configAppDataDir <- get - configScoresFile <- get - configRulesCfgFile <- get - configSavePrefix <- get - configHeroNames <- get - return Config{..} diff --git a/Game/LambdaHack/Server/DungeonGen.hs b/Game/LambdaHack/Server/DungeonGen.hs --- a/Game/LambdaHack/Server/DungeonGen.hs +++ b/Game/LambdaHack/Server/DungeonGen.hs @@ -3,7 +3,7 @@ ( FreshDungeon(..), dungeonGen ) where -import Control.Arrow (first) +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import Data.List @@ -15,7 +15,7 @@ import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.PointXY +import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time @@ -23,24 +23,23 @@ import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Server.DungeonGen.Area -import Game.LambdaHack.Server.DungeonGen.Cave hiding (TileMapXY) +import Game.LambdaHack.Server.DungeonGen.Cave import Game.LambdaHack.Server.DungeonGen.Place -import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency - -convertTileMaps :: Rnd (Kind.Id TileKind) -> Int -> Int -> TileMapXY +convertTileMaps :: Rnd (Kind.Id TileKind) -> Int -> Int -> TileMapEM -> Rnd TileMap convertTileMaps cdefTile cxsize cysize ltile = do - let bounds = (origin, toPoint cxsize $ PointXY (cxsize - 1, cysize - 1)) - assocs = map (first (toPoint cxsize)) (EM.assocs ltile) - pickedTiles <- replicateM (cxsize * cysize) cdefTile - return $ Kind.listArray bounds pickedTiles Kind.// assocs + let f :: Point -> Rnd (Kind.Id TileKind) + f p = case EM.lookup p ltile of + Just t -> return t + Nothing -> cdefTile + PointArray.generateMA cxsize cysize f placeStairs :: Kind.Ops TileKind -> TileMap -> CaveKind -> [Point] -> Rnd Point placeStairs cotile cmap CaveKind{..} ps = do - let dist cmin l _ = all (\pos -> chessDist cxsize l pos > cmin) ps + let dist cmin l _ = all (\pos -> chessDist l pos > cmin) ps findPosTry 1000 cmap (\p t -> Tile.hasFeature cotile F.CanActor t && dist 0 p t) -- can't overwrite stairs with other stairs @@ -57,15 +56,15 @@ , cocave=Kind.Ops{okind=cokind} } Cave{..} ldepth minD maxD nstairUp escapeFeature = do let kc@CaveKind{..} = cokind dkind - fitArea pos = inside cxsize pos . fromArea . qarea - findLegend pos = maybe clitLegendTile qlegend + fitArea pos = inside pos . fromArea . qarea + findLegend pos = maybe clegendLitTile qlegend $ find (fitArea pos) dplaces - hasEscapeAndSymbol sym t = Tile.kindHasFeature (F.Cause Effect.Escape) t - && tsymbol t == sym + hasEscape p t = Tile.kindHasFeature (F.Cause $ Effect.Escape p) t ascendable = Tile.kindHasFeature $ F.Cause (Effect.Ascend 1) descendable = Tile.kindHasFeature $ F.Cause (Effect.Ascend (-1)) dcond kt = not (Tile.kindHasFeature F.Clear kt) - || (if dnight then not else id) (Tile.kindHasFeature F.Lit kt) + || (if dnight then id else not) + (Tile.kindHasFeature F.Dark kt) pickDefTile = fmap (fromMaybe $ assert `failure` cdefTile) $ opick cdefTile dcond cmap <- convertTileMaps pickDefTile cxsize cysize dmap @@ -93,7 +92,7 @@ let st = (spos, stairId) asc = ascendable $ okind stairId desc = descendable $ okind stairId - return $ case (asc, desc) of + return $! case (asc, desc) of (True, False) -> (st : up, down, upDown) (False, True) -> (up, st : down, upDown) (True, True) -> (up, down, st : upDown) @@ -122,15 +121,15 @@ Just True -> do let legend = findLegend epos upEscape <- fmap (fromMaybe $ assert `failure` legend) - $ opick legend $ hasEscapeAndSymbol '<' + $ opick legend $ hasEscape 1 return [(epos, upEscape)] Just False -> do let legend = findLegend epos downEscape <- fmap (fromMaybe $ assert `failure` legend) - $ opick legend $ hasEscapeAndSymbol '>' + $ opick legend $ hasEscape (-1) return [(epos, downEscape)] let exits = stairsTotal ++ escape - ltile = cmap Kind.// exits + ltile = cmap PointArray.// exits -- We reverse the order in down stairs, to minimize long stair chains. lstair = ( map fst $ stairsUp ++ stairsUpDown , map fst $ stairsUpDown ++ stairsDown ) @@ -140,14 +139,15 @@ assert (not $ nullFreq itemFreq) skip lsecret <- random return $! levelFromCaveKind cops kc ldepth ltile lstair - litemNum itemFreq lsecret + litemNum itemFreq lsecret (isJust escapeFeature) levelFromCaveKind :: Kind.COps -> CaveKind -> Int -> TileMap -> ([Point], [Point]) - -> Int -> Frequency Text -> Int + -> Int -> Frequency Text -> Int -> Bool -> Level levelFromCaveKind Kind.COps{cotile} - CaveKind{..} ldepth ltile lstair litemNum litemFreq lsecret = + CaveKind{..} + ldepth ltile lstair litemNum litemFreq lsecret lescape = Level { ldepth , lprio = EM.empty @@ -159,14 +159,15 @@ , ldesc = cname , lstair , lseen = 0 - , lclear = let f !n !tk | Tile.isExplorable cotile tk = n + 1 - | otherwise = n - in Kind.foldlArray f 0 ltile + , lclear = let f n t | Tile.isExplorable cotile t = n + 1 + | otherwise = n + in PointArray.foldlA f 0 ltile , ltime = timeTurn , litemNum , litemFreq , lsecret , lhidden = chidden + , lescape } findGenerator :: Kind.COps -> Caves @@ -210,4 +211,4 @@ assert (nstairUpLast == 0) skip let freshDungeon = EM.fromList levels freshDepth = totalDepth - return FreshDungeon{..} + return $! FreshDungeon{..} diff --git a/Game/LambdaHack/Server/DungeonGen/Area.hs b/Game/LambdaHack/Server/DungeonGen/Area.hs --- a/Game/LambdaHack/Server/DungeonGen/Area.hs +++ b/Game/LambdaHack/Server/DungeonGen/Area.hs @@ -5,7 +5,7 @@ import Data.Binary -import Game.LambdaHack.Common.PointXY +import Game.LambdaHack.Common.Point -- | The type of areas. The bottom left and the top right points. data Area = Area !X !Y !X !Y @@ -20,19 +20,19 @@ fromArea :: Area -> (X, Y, X, Y) fromArea (Area x0 y0 x1 y1) = (x0, y0, x1, y1) -trivialArea :: PointXY -> Area -trivialArea (PointXY (x, y)) = Area x y x y +trivialArea :: Point -> Area +trivialArea (Point x y) = Area x y x y -- | Divide uniformly a larger area into the given number of smaller areas -- overlapping at the edges. -grid :: (X, Y) -> Area -> [(PointXY, Area)] +grid :: (X, Y) -> Area -> [(Point, Area)] grid (nx, ny) (Area x0 y0 x1 y1) = let xd = x1 - x0 -- not +1, because we need overlap yd = y1 - y0 - in [ (PointXY (x, y), Area (x0 + xd * x `div` nx) - (y0 + yd * y `div` ny) - (x0 + xd * (x + 1) `div` nx) - (y0 + yd * (y + 1) `div` ny)) + in [ (Point x y, Area (x0 + xd * x `div` nx) + (y0 + yd * y `div` ny) + (x0 + xd * (x + 1) `div` nx) + (y0 + yd * (y + 1) `div` ny)) | x <- [0..nx-1], y <- [0..ny-1] ] -- | Enlarge (or shrink) the given area on all fours sides by the amount. diff --git a/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs b/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs --- a/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs +++ b/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs @@ -8,24 +8,24 @@ , Corridor, connectPlaces ) where -import qualified Data.EnumSet as ES +import Control.Exception.Assert.Sugar import Data.Maybe +import qualified Data.Set as S -import Game.LambdaHack.Common.PointXY +import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.VectorXY +import Game.LambdaHack.Common.Vector import Game.LambdaHack.Server.DungeonGen.Area -import Control.Exception.Assert.Sugar -- Picking random points inside areas -- | Pick a random point within an area. -xyInArea :: Area -> Rnd PointXY +xyInArea :: Area -> Rnd Point xyInArea area = do let (x0, y0, x1, y1) = fromArea area rx <- randomR (x0, x1) ry <- randomR (y0, y1) - return $ PointXY (rx, ry) + return $! Point rx ry -- | Create a random room according to given parameters. mkRoom :: (X, Y) -- ^ minimum size @@ -37,17 +37,17 @@ assert (xm <= x1 - x0 + 1 && ym <= y1 - y0 + 1) skip let a0 = (x0, y0, x1 - xm + 1, y1 - ym + 1) area0 = fromMaybe (assert `failure` a0) $ toArea a0 - PointXY (rx0, ry0) <- xyInArea area0 + Point rx0 ry0 <- xyInArea area0 let sX = rx0 + xm - 1 sY = ry0 + ym - 1 eX = min x1 (rx0 + xM - 1) eY = min y1 (ry0 + yM - 1) a1 = (sX, sY, eX, eY) area1 = fromMaybe (assert `failure` a1) $ toArea a1 - PointXY (rx1, ry1) <- xyInArea area1 + Point rx1 ry1 <- xyInArea area1 let a3 = (rx0, ry0, rx1, ry1) area3 = fromMaybe (assert `failure` a3) $ toArea a3 - return area3 + return $! area3 -- | Create a void room, i.e., a single point area within the designated area. mkVoidRoom :: Area -> Rnd Area @@ -55,45 +55,50 @@ -- Pass corridors closer to the middle of the grid area, if possible. let core = fromMaybe area $ shrink area pxy <- xyInArea core - return $ trivialArea pxy + return $! trivialArea pxy -- Choosing connections between areas in a grid -- | Pick a subset of connections between adjacent areas within a grid until -- there is only one connected component in the graph of all areas. -connectGrid :: (X, Y) -> Rnd [(PointXY, PointXY)] +connectGrid :: (X, Y) -> Rnd [(Point, Point)] connectGrid (nx, ny) = do - let unconnected = ES.fromList [ PointXY (x, y) + let unconnected = S.fromList [ Point x y | x <- [0..nx-1], y <- [0..ny-1] ] -- Candidates are neighbours that are still unconnected. We start with -- a random choice. rx <- randomR (0, nx-1) ry <- randomR (0, ny-1) - let candidates = ES.fromList [ PointXY (rx, ry) ] + let candidates = S.fromList [Point rx ry] connectGrid' (nx, ny) unconnected candidates [] -connectGrid' :: (X, Y) -> ES.EnumSet PointXY -> ES.EnumSet PointXY - -> [(PointXY, PointXY)] - -> Rnd [(PointXY, PointXY)] +connectGrid' :: (X, Y) -> S.Set Point -> S.Set Point + -> [(Point, Point)] + -> Rnd [(Point, Point)] connectGrid' (nx, ny) unconnected candidates acc - | ES.null candidates = return $ map sortPointXY acc + | S.null candidates = return $! map sortPoint acc | otherwise = do - c <- oneOf (ES.toList candidates) + c <- oneOf (S.toList candidates) -- potential new candidates: - let ns = ES.fromList $ vicinityCardinalXY (0, 0, nx-1, ny-1) c - nu = ES.delete c unconnected -- new unconnected + let ns = S.fromList $ vicinityCardinal nx ny c + nu = S.delete c unconnected -- new unconnected -- (new candidates, potential connections): - (nc, ds) = ES.partition (`ES.member` nu) ns - new <- if ES.null ds + (nc, ds) = S.partition (`S.member` nu) ns + new <- if S.null ds then return id else do - d <- oneOf (ES.toList ds) + d <- oneOf (S.toList ds) return ((c, d) :) connectGrid' (nx, ny) nu - (ES.delete c (candidates `ES.union` nc)) (new acc) + (S.delete c (candidates `S.union` nc)) (new acc) +-- | Sort the sequence of two points, in the derived lexicographic order. +sortPoint :: (Point, Point) -> (Point, Point) +sortPoint (a, b) | a <= b = (a, b) + | otherwise = (b, a) + -- | Pick a single random connection between adjacent areas within a grid. -randomConnection :: (X, Y) -> Rnd (PointXY, PointXY) +randomConnection :: (X, Y) -> Rnd (Point, Point) randomConnection (nx, ny) = assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` "wrong connection" `twith` (nx, ny)) $ do @@ -102,11 +107,11 @@ then do rx <- randomR (0, nx-2) ry <- randomR (0, ny-1) - return (PointXY (rx, ry), PointXY (rx+1, ry)) + return (Point rx ry, Point (rx+1) ry) else do rx <- randomR (0, nx-1) ry <- randomR (0, ny-2) - return (PointXY (rx, ry), PointXY (rx, ry+1)) + return (Point rx ry, Point rx (ry+1)) -- Plotting individual corridors between two areas @@ -114,20 +119,20 @@ data HV = Horiz | Vert -- | The coordinates of consecutive fields of a corridor. -type Corridor = [PointXY] +type Corridor = [Point] -- | Create a corridor, either horizontal or vertical, with -- a possible intermediate part that is in the opposite direction. mkCorridor :: HV -- ^ orientation of the starting section - -> PointXY -- ^ starting point - -> PointXY -- ^ ending point + -> Point -- ^ starting point + -> Point -- ^ ending point -> Area -- ^ the area containing the intermediate point -> Rnd Corridor -- ^ straight sections of the corridor -mkCorridor hv (PointXY (x0, y0)) (PointXY (x1, y1)) b = do - PointXY (rx, ry) <- xyInArea b - case hv of - Horiz -> return $ map PointXY [(x0, y0), (rx, y0), (rx, y1), (x1, y1)] - Vert -> return $ map PointXY [(x0, y0), (x0, ry), (x1, ry), (x1, y1)] +mkCorridor hv (Point x0 y0) (Point x1 y1) b = do + Point rx ry <- xyInArea b + return $! map (uncurry Point) $ case hv of + Horiz -> [(x0, y0), (rx, y0), (rx, y1), (x1, y1)] + Vert -> [(x0, y0), (x0, ry), (x1, ry), (x1, y1)] -- | Try to connect two interiors of places with a corridor. -- Choose entrances at least 4 or 3 tiles distant from the edges, if the place @@ -150,8 +155,8 @@ (nx0, nx1) = trim4 (x0, x1) (ny0, ny1) = trim4 (y0, y1) in fromMaybe (assert `failure` area) $ toArea (nx0, ny0, nx1, ny1) - PointXY (sx, sy) <- xyInArea $ trim so - PointXY (tx, ty) <- xyInArea $ trim to + Point sx sy <- xyInArea $ trim so + Point tx ty <- xyInArea $ trim to let hva sarea tarea = do let (_, _, zsx1, zsy1) = fromArea sarea (ztx0, zty0, _, _) = fromArea tarea @@ -176,8 +181,8 @@ -- We cross width one places completely with the corridor, for void -- rooms and others (e.g., one-tile wall room then becomes a door, etc.). let (p0, p1) = case hv of - Horiz -> (PointXY (sox1, sy), PointXY (tox0, ty)) - Vert -> (PointXY (sx, soy1), PointXY (tx, toy0)) + Horiz -> (Point sox1 sy, Point tox0 ty) + Vert -> (Point sx soy1, Point tx toy0) -- The condition imposed on mkCorridor are tricky: there might not always -- exist a good intermediate point if the places are allowed to be close -- together and then we let the intermediate part degenerate. diff --git a/Game/LambdaHack/Server/DungeonGen/Cave.hs b/Game/LambdaHack/Server/DungeonGen/Cave.hs --- a/Game/LambdaHack/Server/DungeonGen/Cave.hs +++ b/Game/LambdaHack/Server/DungeonGen/Cave.hs @@ -1,18 +1,19 @@ -- | Generation of caves (not yet inhabited dungeon levels) from cave kinds. module Game.LambdaHack.Server.DungeonGen.Cave - ( TileMapXY, ItemFloorXY, Cave(..), buildCave + ( Cave(..), buildCave ) where import Control.Arrow ((&&&)) +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM -import qualified Data.List as L +import Data.List +import qualified Data.Map.Strict as M import Data.Maybe +import qualified Data.Traversable as Traversable -import qualified Game.LambdaHack.Common.Feature as F -import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.PointXY +import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Content.CaveKind @@ -20,24 +21,12 @@ import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Server.DungeonGen.Area import Game.LambdaHack.Server.DungeonGen.AreaRnd -import Game.LambdaHack.Server.DungeonGen.Place hiding (TileMapXY) -import qualified Game.LambdaHack.Server.DungeonGen.Place as Place -import Control.Exception.Assert.Sugar - --- | The map of tile kinds in a cave. --- The map is sparse. The default tile that eventually fills the empty spaces --- is specified in the cave kind specification with @cdefTile@. -type TileMapXY = Place.TileMapXY - --- | The map of starting items in tiles of a cave. The map is sparse. --- Unspecified tiles have no starting items. -type ItemFloorXY = EM.EnumMap PointXY (Item, Int) +import Game.LambdaHack.Server.DungeonGen.Place -- | The type of caves (not yet inhabited dungeon levels). data Cave = Cave { dkind :: !(Kind.Id CaveKind) -- ^ the kind of the cave - , dmap :: !TileMapXY -- ^ tile kinds in the cave - , ditem :: !ItemFloorXY -- ^ starting items in the cave + , dmap :: !TileMapEM -- ^ tile kinds in the cave , dplaces :: ![Place] -- ^ places generated in the cave , dnight :: !Bool -- ^ whether the cave is dark } @@ -72,20 +61,21 @@ -> Int -- ^ maximum depth of the dungeon -> Kind.Id CaveKind -- ^ cave kind to use for generation -> Rnd Cave -buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{ opick - , ouniqGroup } +buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{opick} , cocave=Kind.Ops{okind} , coplace=Kind.Ops{okind=pokind} } - ln depth ci = do - let kc@CaveKind{..} = okind ci + ln depth dkind = do + let kc@CaveKind{..} = okind dkind lgrid@(gx, gy) <- castDiceXY cgrid -- Make sure that in caves not filled with rock, there is a passage -- across the cave, even if a single room blocks most of the cave. + -- Also, ensure fancy outer fences are not obstructed by room walls. let fullArea = fromMaybe (assert `failure` kc) $ toArea (0, 0, cxsize - 1, cysize - 1) subFullArea = fromMaybe (assert `failure` kc) $ toArea (1, 1, cxsize - 2, cysize - 2) - area | gx == 1 || gy == 1 = subFullArea + area | gx * gy == 1 + || couterFenceTile /= "basic outer fence" = subFullArea | otherwise = fullArea gs = grid lgrid area (addedConnects, voidPlaces) <- do @@ -110,8 +100,7 @@ else fmap Right $ mkRoom minPlaceSize maxPlaceSize innerArea return (i, r')) gs - let hardRockId = ouniqGroup "outer fence" - fence = buildFence hardRockId subFullArea + fence <- buildFenceRnd cops couterFenceTile subFullArea dnight <- chanceDeep ln depth cnightChance darkCorTile <- fmap (fromMaybe $ assert `failure` cdarkCorTile) $ opick cdarkCorTile (const True) @@ -120,12 +109,13 @@ let pickedCorTile = if dnight then darkCorTile else litCorTile addPl (m, pls, qls) (i, Left r) = return (m, pls, (i, Left r) : qls) addPl (m, pls, qls) (i, Right r) = do - (tmap, place) <- buildPlace cops kc darkCorTile litCorTile ln depth r + (tmap, place) <- + buildPlace cops kc dnight darkCorTile litCorTile ln depth r return (EM.union tmap m, place : pls, (i, Right (r, place)) : qls) (lplaces, dplaces, qplaces0) <- foldM addPl (fence, [], []) places0 connects <- connectGrid lgrid - let allConnects = L.union connects addedConnects -- no duplicates - qplaces = EM.fromList qplaces0 + let allConnects = union connects addedConnects -- no duplicates + qplaces = M.fromList qplaces0 cs <- mapM (\(p0, p1) -> do let shrinkPlace (r, Place{qkind}) = case shrink r of @@ -139,45 +129,47 @@ Just mergeArea -> (mergeArea, r) _ -> (sr, sr) shrinkForFence = either (id &&& id) shrinkPlace - rr0 = shrinkForFence $ qplaces EM.! p0 - rr1 = shrinkForFence $ qplaces EM.! p1 + rr0 = shrinkForFence $ qplaces M.! p0 + rr1 = shrinkForFence $ qplaces M.! p1 connectPlaces rr0 rr1) allConnects - let lcorridors = EM.unions (L.map (digCorridors pickedCorTile) cs) + let lcorridors = EM.unions (map (digCorridors pickedCorTile) cs) lm = EM.unionWith (mergeCorridor cotile) lcorridors lplaces -- Convert wall openings into doors, possibly. - let f l (p, t) = - if not $ Tile.hasFeature cotile F.Suspect t - then return l -- no opening to start with + let f t = + if not $ Tile.isSuspect cotile t + -- May also turn a cache into a floor (and/or a pillar?); tough luck. + -- TODO: the floor may be lit while it should be dark. + then return t -- no opening to start with else do -- Openings have a certain chance to be doors -- and doors have a certain chance to be open. rd <- chance cdoorChance if not rd then - return $ EM.insert p pickedCorTile l -- opening kept + let cor = if Tile.isLit cotile t then litCorTile else darkCorTile + in return $! cor -- opening kept else do ro <- chance copenChance doorClosedId <- Tile.revealAs cotile t if not ro then - return $ EM.insert p doorClosedId l + return $! doorClosedId else do doorOpenId <- Tile.openTo cotile doorClosedId - return $ EM.insert p doorOpenId l - dmap <- foldM f lm (EM.assocs lm) + return $! doorOpenId + dmap <- Traversable.mapM f lm let cave = Cave - { dkind = ci - , ditem = EM.empty + { dkind , dmap , dplaces , dnight } - return cave + return $! cave -digCorridors :: Kind.Id TileKind -> Corridor -> TileMapXY +digCorridors :: Kind.Id TileKind -> Corridor -> TileMapEM digCorridors tile (p1:p2:ps) = EM.union corPos (digCorridors tile (p2:ps)) where - corXY = fromTo p1 p2 - corPos = EM.fromList $ L.zip corXY (repeat tile) + cor = fromTo p1 p2 + corPos = EM.fromList $ zip cor (repeat tile) digCorridors _ _ = EM.empty mergeCorridor :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind diff --git a/Game/LambdaHack/Server/DungeonGen/Place.hs b/Game/LambdaHack/Server/DungeonGen/Place.hs --- a/Game/LambdaHack/Server/DungeonGen/Place.hs +++ b/Game/LambdaHack/Server/DungeonGen/Place.hs @@ -1,26 +1,25 @@ {-# LANGUAGE RankNTypes #-} -- | Generation of places from place kinds. module Game.LambdaHack.Server.DungeonGen.Place - ( TileMapXY, Place(..), placeCheck, buildFence, buildPlace + ( TileMapEM, Place(..), placeCheck, buildFenceRnd, buildPlace ) where +import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import qualified Data.List as L import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.PointXY +import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Server.DungeonGen.Area -import Control.Exception.Assert.Sugar -- TODO: use more, rewrite as needed, document each field. -- | The parameters of a place. Most are immutable and set @@ -38,7 +37,7 @@ -- | The map of tile kinds in a place (and generally anywhere in a cave). -- The map is sparse. The default tile that eventually fills the empty spaces -- is specified in the cave kind specification with @cdefTile@. -type TileMapXY = EM.EnumMap PointXY (Kind.Id TileKind) +type TileMapEM = EM.EnumMap Point (Kind.Id TileKind) -- | For @CAlternate@ tiling, require the place be comprised -- of an even number of whole corners, with exactly one square @@ -56,7 +55,7 @@ dx = x1 - x0 + 1 dy = y1 - y0 + 1 dxcorner = case ptopLeft of [] -> 0 ; l : _ -> T.length l - dycorner = L.length ptopLeft + dycorner = length ptopLeft wholeOverlapped d dcorner = d > 1 && dcorner > 1 && (d - 1) `mod` (2 * (dcorner - 1)) == 0 in case pcover of @@ -80,15 +79,16 @@ -- and fill a cave section acccording to it. buildPlace :: Kind.COps -- ^ the game content -> CaveKind -- ^ current cave kind + -> Bool -- ^ whether the cave is dark -> Kind.Id TileKind -- ^ dark fence tile, if fence hollow -> Kind.Id TileKind -- ^ lit fence tile, if fence hollow -> Int -- ^ current level depth -> Int -- ^ maximum depth -> Area -- ^ whole area of the place, fence included - -> Rnd (TileMapXY, Place) + -> Rnd (TileMapEM, Place) buildPlace Kind.COps{ cotile=cotile@Kind.Ops{opick=opick} , coplace=Kind.Ops{okind=pokind, opick=popick} } - CaveKind{..} darkCorTile litCorTile ln depth r = do + CaveKind{..} dnight darkCorTile litCorTile ln depth r = do qsolidFence <- fmap (fromMaybe $ assert `failure` cfillerTile) $ opick cfillerTile (const True) dark <- chanceDeep ln depth cdarkChance @@ -97,56 +97,75 @@ $ popick cave (placeCheck r) let qhollowFence = if dark then darkCorTile else litCorTile kr = pokind qkind - qlegend = if dark then cdarkLegendTile else clitLegendTile + qlegend = if dark then clegendDarkTile else clegendLitTile qseen = False qarea = fromMaybe (assert `failure` (kr, r)) $ interiorArea (pfence kr) r place = Place {..} legend <- olegend cotile qlegend + legendLit <- olegend cotile clegendLitTile let xlegend = EM.insert 'X' qhollowFence legend - return (digPlace place kr xlegend, place) + xlegendLit = EM.insert 'X' qhollowFence legendLit + cmap = tilePlace qarea kr + fence = case pfence kr of + FWall -> buildFence qsolidFence qarea + FFloor -> buildFence qhollowFence qarea + FNone -> EM.empty + (x0, y0, x1, y1) = fromArea qarea + isEdge (Point x y) = x `elem` [x0, x1] || y `elem` [y0, y1] + digNight xy c | isEdge xy = xlegendLit EM.! c + | otherwise = xlegend EM.! c + interior = case pfence kr of + FNone | not dnight -> EM.mapWithKey digNight cmap + _ -> EM.map (xlegend EM.!) cmap + tmap = EM.union interior fence + return (tmap, place) -- | Roll a legend of a place plan: a map from plan symbols to tile kinds. olegend :: Kind.Ops TileKind -> Text -> Rnd (EM.EnumMap Char (Kind.Id TileKind)) -olegend Kind.Ops{ofoldrWithKey, opick} group = +olegend Kind.Ops{ofoldrWithKey, opick} cgroup = let getSymbols _ tk acc = maybe acc (const $ ES.insert (tsymbol tk) acc) - (L.lookup group $ tfreq tk) + (lookup cgroup $ tfreq tk) symbols = ofoldrWithKey getSymbols ES.empty getLegend s acc = do m <- acc - tk <- fmap (fromMaybe $ assert `failure` (group, s)) - $ opick group $ (== s) . tsymbol - return $ EM.insert s tk m + tk <- fmap (fromMaybe $ assert `failure` (cgroup, s)) + $ opick cgroup $ (== s) . tsymbol + return $! EM.insert s tk m legend = ES.foldr getLegend (return EM.empty) symbols in legend -- | Construct a fence around an area, with the given tile kind. -buildFence :: Kind.Id TileKind -> Area -> TileMapXY +buildFence :: Kind.Id TileKind -> Area -> TileMapEM buildFence fenceId area = let (x0, y0, x1, y1) = fromArea area - in EM.fromList $ [ (PointXY (x, y), fenceId) + in EM.fromList $ [ (Point x y, fenceId) | x <- [x0-1, x1+1], y <- [y0..y1] ] ++ - [ (PointXY (x, y), fenceId) + [ (Point x y, fenceId) | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ] --- | Construct a place of the given kind, with the given fence tile. -digPlace :: Place -- ^ the place parameters - -> PlaceKind -- ^ the place kind - -> EM.EnumMap Char (Kind.Id TileKind) -- ^ the legend - -> TileMapXY -digPlace Place{..} kr legend = - let fence = case pfence kr of - FWall -> buildFence qsolidFence qarea - FFloor -> buildFence qhollowFence qarea - FNone -> EM.empty - in EM.union (EM.map (legend EM.!) $ tilePlace qarea kr) fence +-- | Construct a fence around an area, with the given tile group. +buildFenceRnd :: Kind.COps -> Text -> Area -> Rnd TileMapEM +buildFenceRnd Kind.COps{cotile=Kind.Ops{opick}} couterFenceTile area = do + let (x0, y0, x1, y1) = fromArea area + fenceIdRnd (xf, yf) = do + let isCorner x y = x `elem` [x0-1, x1+1] && y `elem` [y0-1, y1+1] + tileGroup | isCorner xf yf = "basic outer fence" + | otherwise = couterFenceTile + fenceId <- fmap (fromMaybe $ assert `failure` tileGroup) + $ opick tileGroup (const True) + return (Point xf yf, fenceId) + pointList = [ (x, y) | x <- [x0-1, x1+1], y <- [y0..y1] ] + ++ [ (x, y) | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ] + fenceList <- mapM fenceIdRnd pointList + return $! EM.fromList fenceList -- TODO: use Text more instead of [Char]? -- | Create a place by tiling patterns. tilePlace :: Area -- ^ the area to fill -> PlaceKind -- ^ the place kind to construct - -> EM.EnumMap PointXY Char + -> EM.EnumMap Point Char tilePlace area pl@PlaceKind{..} = let (x0, y0, x1, y1) = fromArea area xwidth = x1 - x0 + 1 @@ -155,33 +174,34 @@ [] -> assert `failure` (area, pl) l : _ -> T.length l (dx, dy) = assert (xwidth >= dxcorner && ywidth >= length ptopLeft - `blame` (area, pl)) (xwidth, ywidth) - fromX (x, y) = L.map PointXY $ L.zip [x..] (repeat y) - fillInterior :: (forall a. Int -> [a] -> [a]) -> [(PointXY, Char)] + `blame` (area, pl)) + (xwidth, ywidth) + fromX (x2, y2) = + zipWith (\x y -> Point x y) [x2..] (repeat y2) + fillInterior :: (forall a. Int -> [a] -> [a]) -> [(Point, Char)] fillInterior f = - let tileInterior (y, row) = L.zip (fromX (x0, y)) $ f dx row - reflected = L.zip [y0..] $ f dy $ map T.unpack ptopLeft - in L.concatMap tileInterior reflected + let tileInterior (y, row) = zip (fromX (x0, y)) $ f dx row + reflected = zip [y0..] $ f dy $ map T.unpack ptopLeft + in concatMap tileInterior reflected tileReflect :: Int -> [a] -> [a] tileReflect d pat = - let lstart = L.take (d `divUp` 2) pat - lend = L.take (d `div` 2) pat - in lstart ++ L.reverse lend + let lstart = take (d `divUp` 2) pat + lend = take (d `div` 2) pat + in lstart ++ reverse lend interior = case pcover of CAlternate -> let tile :: Int -> [a] -> [a] tile _ [] = assert `failure` "nothing to tile" `twith` pl - tile d pat = - L.take d (L.cycle $ L.init pat ++ L.init (L.reverse pat)) + tile d pat = take d (cycle $ init pat ++ init (reverse pat)) in fillInterior tile CStretch -> let stretch :: Int -> [a] -> [a] stretch _ [] = assert `failure` "nothing to stretch" `twith` pl - stretch d pat = tileReflect d (pat ++ L.repeat (L.last pat)) + stretch d pat = tileReflect d (pat ++ repeat (last pat)) in fillInterior stretch CReflect -> let reflect :: Int -> [a] -> [a] - reflect d pat = tileReflect d (L.cycle pat) + reflect d pat = tileReflect d (cycle pat) in fillInterior reflect in EM.fromList interior @@ -200,4 +220,4 @@ qlegend <- get qsolidFence <- get qhollowFence <- get - return Place{..} + return $! Place{..} diff --git a/Game/LambdaHack/Server/EffectSem.hs b/Game/LambdaHack/Server/EffectSem.hs --- a/Game/LambdaHack/Server/EffectSem.hs +++ b/Game/LambdaHack/Server/EffectSem.hs @@ -4,9 +4,11 @@ ( -- + Semantics of effects itemEffect, effectSem -- * Assorted operations - , createItems, addHero, spawnMonsters, pickFaction, electLeader, deduceKilled + , registerItem, createItems, addHero, spawnMonsters + , electLeader, deduceKilled ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM @@ -18,7 +20,6 @@ import Data.Text (Text) import qualified NLP.Miniutter.English as MU -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState @@ -37,8 +38,8 @@ import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Server.Action -import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.State import Game.LambdaHack.Utils.Frequency @@ -53,14 +54,16 @@ => ActorId -> ActorId -> Maybe ItemId -> Item -> m () itemEffect source target miid item = do - sb <- getsState $ getActorBody source discoS <- getsServer sdisco let ik = fromJust $ jkind discoS item ef = jeffect item b <- effectSem ef source target -- The effect is interesting so the item gets identified, if seen - -- (the item is in source actor's inventory, so his position is given). - let atomic iid = execCmdAtomic $ DiscoverA (blid sb) (bpos sb) iid ik + -- (the item is in source actor's inventory, so his position is given, + -- note that the actor may be moved by the effect; the item is destroyed, + -- if ever, after the discovery happens). + postb <- getsState $ getActorBody source + let atomic iid = execCmdAtomic $ DiscoverA (blid postb) (bpos postb) iid ik when b $ maybe skip atomic miid -- | The source actor affects the target actor, with a given effect and power. @@ -84,7 +87,7 @@ Effect.Regeneration p -> effectSem (Effect.Heal p) source target Effect.Searching p -> effectSearching p source Effect.Ascend p -> effectAscend p target - Effect.Escape -> effectEscape target + Effect.Escape{} -> effectEscape target -- + Individual semantic functions for effects @@ -166,6 +169,7 @@ execSfxAtomic $ EffectD target Effect.Dominate -- TODO: Perhaps insert a turn of delay here to allow countermeasures. electLeader (bfid tb) (blid tb) target + deduceKilled tb ais <- getsState $ getActorItem target execCmdAtomic $ LoseActorA target tb ais let bNew = tb {bfid = bfid sb} @@ -177,7 +181,6 @@ when (delta > speedZero) $ execCmdAtomic $ HasteActorA target (speedNegate delta) execCmdAtomic $ LeadFactionA (bfid sb) leaderOld (Just target) - deduceKilled tb -- tb (not bNew), because that's how we saw him last return True electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m () @@ -195,13 +198,15 @@ deduceKilled :: (MonadAtomic m, MonadServer m) => Actor -> m () deduceKilled body = do - let fid = bfid body + cops@Kind.COps{corule} <- getsState scops + let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule + fid = bfid body spawn <- getsState $ isSpawnFaction fid - summon <- getsState $ isSummonFaction fid - Config{configFirstDeathEnds} <- getsServer sconfig + fact <- getsState $ (EM.! fid) . sfactionD + let horror = isHorrorFact cops fact mleader <- getsState $ gleader . (EM.! fid) . sfactionD - when (not spawn && not summon - && (isNothing mleader || configFirstDeathEnds)) $ + when (not spawn && not horror + && (isNothing mleader || firstDeathEnds)) $ deduceQuits body $ Status Killed (fromEnum $ blid body) "" -- ** SummonFriend @@ -242,22 +247,28 @@ -> Char -> Text -> Color.Color -> Time -> m ActorId addActor mk bfid pos lid hp bsymbol bname bcolor time = do - Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops - let kind = okind mk + Kind.COps{coactor=coactor@Kind.Ops{okind}} <- getsState scops + Faction{gplayer} <- getsState $ (EM.! bfid) . sfactionD + DebugModeSer{sdifficultySer} <- getsServer sdebugSer + nU <- nUI + -- If no UI factions, the difficulty applies to heroes (for testing). + let diffHP | playerUI gplayer || nU == 0 && mk == heroKindId coactor = + (ceiling :: Double -> Int) $ fromIntegral hp * 1.5 ^^ sdifficultySer + | otherwise = hp + kind = okind mk speed = aspeed kind - m = actorTemplate mk bsymbol bname bcolor speed hp Nothing pos lid time - bfid False + m = actorTemplate mk bsymbol bname bcolor speed diffHP + Nothing pos lid time bfid False acounter <- getsServer sacounter modifyServer $ \ser -> ser {sacounter = succ acounter} execCmdAtomic $ CreateActorA acounter m [] - return acounter + return $! acounter --- TODO: apply this special treatment only to actors with symbol '@'. -- | Create a new hero on the current level, close to the given position. addHero :: (MonadAtomic m, MonadServer m) => FactionId -> Point -> LevelId -> [(Int, Text)] -> Maybe Int -> Time -> m ActorId -addHero bfid ppos lid configHeroNames mNumber time = do +addHero bfid ppos lid heroNames mNumber time = do Kind.COps{coactor=coactor@Kind.Ops{okind}} <- getsState scops Faction{gcolor, gplayer} <- getsState $ (EM.! bfid) . sfactionD let kId = heroKindId coactor @@ -266,12 +277,14 @@ let freeHeroK = elemIndex Nothing mhs n = fromMaybe (fromMaybe 100 freeHeroK) mNumber symbol = if n < 1 || n > 9 then '@' else Char.intToDigit n + nameFromNumber 0 = "Captain" + nameFromNumber k = "Hero" <+> tshow k name | gcolor == Color.BrWhite = - fromMaybe ("Hero" <+> showT n) $ lookup n configHeroNames - | otherwise = playerName gplayer <+> "Hero" <+> showT n - startHP = hp - (hp `div` 5) * min 3 n - addActor - kId bfid ppos lid startHP symbol name gcolor time + fromMaybe (nameFromNumber n) $ lookup n heroNames + | otherwise = + playerName gplayer <+> nameFromNumber n + startHP = hp - (min 10 $ hp `div` 10) * min 5 n + addActor kId bfid ppos lid startHP symbol name gcolor time -- ** SpawnMonster @@ -290,8 +303,9 @@ spawnMonsters (take power ps) (blid tm) time fid return True --- | Spawn monsters of any spawn or summon faction, friendly or not. --- To be used for spontaneous spawning of monsters and for the summon effect. +-- | Spawn non-hero actors of any faction, friendly or not. +-- To be used for initial dungeon population, spontaneous spawning +-- of monsters and for the summon effect. spawnMonsters :: (MonadAtomic m, MonadServer m) => [Point] -> LevelId -> Time -> FactionId -> m () @@ -352,21 +366,31 @@ discoRev <- getsServer sdiscoRev Level{ldepth, litemFreq} <- getLevel lid depth <- getsState sdepth + let container = CFloor lid pos replicateM_ n $ do (item, k, _) <- rndToAction $ newItem coitem flavour discoRev litemFreq ldepth depth - itemRev <- getsServer sitemRev - case HM.lookup item itemRev of - Just iid -> - -- TODO: try to avoid this case, to make items more interesting - execCmdAtomic $ CreateItemA iid item k (CFloor lid pos) - Nothing -> do - icounter <- getsServer sicounter - modifyServer $ \ser -> - ser { sicounter = succ icounter - , sitemRev = HM.insert item icounter (sitemRev ser) } - execCmdAtomic $ CreateItemA icounter item k (CFloor lid pos) + void $ registerItem item k container True +registerItem :: (MonadAtomic m, MonadServer m) + => Item -> Int -> Container -> Bool -> m ItemId +registerItem item k container verbose = do + itemRev <- getsServer sitemRev + let cmd = if verbose then CreateItemA else SpotItemA + case HM.lookup item itemRev of + Just iid -> do + -- TODO: try to avoid this case for createItems, + -- to make items more interesting + execCmdAtomic $ cmd iid item k container + return iid + Nothing -> do + icounter <- getsServer sicounter + modifyServer $ \ser -> + ser { sicounter = succ icounter + , sitemRev = HM.insert item icounter (sitemRev ser) } + execCmdAtomic $ cmd icounter item k container + return $! icounter + -- ** ApplyPerfume effectApplyPerfume :: MonadAtomic m @@ -399,56 +423,67 @@ effectAscend :: MonadAtomic m => Int -> ActorId -> m Bool effectAscend power target = do - b <- effLvlGoUp target power - when b $ execSfxAtomic $ EffectD target $ Effect.Ascend power - return b + mfail <- effLvlGoUp target power + case mfail of + Nothing -> do + execSfxAtomic $ EffectD target $ Effect.Ascend power + return True + Just failMsg -> do + b <- getsState $ getActorBody target + execSfxAtomic $ MsgFidD (bfid b) failMsg + return False -effLvlGoUp :: MonadAtomic m => ActorId -> Int -> m Bool +effLvlGoUp :: MonadAtomic m => ActorId -> Int -> m (Maybe Msg) effLvlGoUp aid k = do b1 <- getsState $ getActorBody aid ais1 <- getsState $ getActorItem aid let lid1 = blid b1 pos1 = bpos b1 - (lid2, pos2) <- getsState $ whereTo lid1 pos1 k - if lid2 == lid1 && pos2 == pos1 || bproj b1 then - return False + (lid2, pos2) <- getsState $ whereTo lid1 pos1 k . sdungeon + if lid2 == lid1 && pos2 == pos1 then + return $ Just "The effect fizzles: no more levels in this direction." + else if bproj b1 then + assert `failure` "projectiles can't exit levels" `twith` (aid, k, b1) else do + let switch1 = switchLevels1 ((aid, b1), ais1) + switch2 = do + -- Move the actor to where the inhabitant was, if any. + switchLevels2 lid2 pos2 ((aid, b1), ais1) + -- Verify only one non-projectile actor on every tile. + !_ <- getsState $ posToActors pos1 lid1 -- assertion is inside + !_ <- getsState $ posToActors pos2 lid2 -- assertion is inside + return Nothing -- The actor is added to the new level, but there can be other actors -- at his new position. - inhabitants <- getsState $ posToActor pos2 lid2 + inhabitants <- getsState $ posToActors pos2 lid2 case inhabitants of - Nothing -> - -- Move the actor out of the way. - switchLevels1 aid - Just aid2 -> do - b2 <- getsState $ getActorBody aid2 - ais2 <- getsState $ getActorItem aid2 + [] -> do + switch1 + switch2 + ((_, b2), _) : _ -> do -- Alert about the switch. - let part2 = partActor b2 + let subjects = map (partActor . snd . fst) inhabitants + subject = MU.WWandW subjects verb = "be pushed to another level" - msg2 = makeSentence [MU.SubjectVerbSg part2 verb] + msg2 = makeSentence [MU.SubjectVerbSg subject verb] + -- Only tell one player, even if many actors, because then + -- they are projectiles, so not too important. execSfxAtomic $ MsgFidD (bfid b2) msg2 -- Move the actor out of the way. - switchLevels1 aid + switch1 -- Move the inhabitant out of the way. - switchLevels1 aid2 + mapM_ switchLevels1 inhabitants -- Move the inhabitant to where the actor was. - switchLevels2 aid2 b2 ais2 lid1 pos1 - -- Move the actor to where the inhabitant was, if any. - switchLevels2 aid b1 ais1 lid2 pos2 - -- Verify only one actor on every tile. - !_ <- getsState $ posToActor pos1 lid1 -- assertion is inside - !_ <- getsState $ posToActor pos2 lid2 -- assertion is inside - return True + mapM_ (switchLevels2 lid1 pos1) inhabitants + switch2 -switchLevels1 :: MonadAtomic m => ActorId -> m () -switchLevels1 aid = do - bOld <- getsState $ getActorBody aid - ais <- getsState $ getActorItem aid +switchLevels1 :: MonadAtomic m => ((ActorId, Actor), [(ItemId, Item)]) -> m () +switchLevels1 ((aid, bOld), ais) = do let side = bfid bOld mleader <- getsState $ gleader . (EM.! side) . sfactionD -- Prevent leader pointing to a non-existing actor. - when (isJust mleader) $ -- trouble, if the actors are of the same faction + when (not (bproj bOld) && isJust mleader) $ + -- Trouble, if the actors are of the same faction. execCmdAtomic $ LeadFactionA side mleader Nothing -- Remove the actor from the old level. -- Onlookers see somebody disappear suddenly. @@ -456,9 +491,9 @@ execCmdAtomic $ LoseActorA aid bOld ais switchLevels2 :: MonadAtomic m - => ActorId -> Actor -> [(ItemId, Item)] -> LevelId -> Point + => LevelId -> Point -> ((ActorId, Actor), [(ItemId, Item)]) -> m () -switchLevels2 aid bOld ais lidNew posNew = do +switchLevels2 lidNew posNew ((aid, bOld), ais) = do let lidOld = blid bOld side = bfid bOld assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) skip @@ -471,10 +506,9 @@ let delta = timeAdd (btime bOld) (timeNegate timeOld) bNew = bOld { blid = lidNew , btime = timeAdd timeLastVisited delta - , bwait = timeZero -- no longer braced , bpos = posNew , boldpos = posNew -- new level, new direction - , bpath = Nothing } + , boldlid = lidOld } -- record old level mleader <- getsState $ gleader . (EM.! side) . sfactionD -- Materialize the actor at the new location. -- Onlookers see somebody appear suddenly. The actor himself @@ -483,7 +517,8 @@ -- Changing levels is so important, that the leader changes. -- This also helps the actor clear the staircase and so avoid -- being pushed back to the level he came from by another actor. - when (isNothing mleader) $ -- trouble, if the actors are of the same faction + when (not (bproj bOld) && isNothing mleader) $ + -- Trouble, if the actors are of the same faction. execCmdAtomic $ LeadFactionA side Nothing (Just aid) -- ** Escape @@ -492,11 +527,12 @@ effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> m Bool effectEscape aid = do -- Obvious effect, nothing announced. + cops <- getsState scops b <- getsState $ getActorBody aid let fid = bfid b - spawn <- getsState $ isSpawnFaction fid - summon <- getsState $ isSummonFaction fid - if spawn || summon || bproj b then return False + fact <- getsState $ (EM.! fid) . sfactionD + if not (isHeroFact cops fact) || bproj b then + return False else do deduceQuits b $ Status Escape (fromEnum $ blid b) "" return True diff --git a/Game/LambdaHack/Server/Fov.hs b/Game/LambdaHack/Server/Fov.hs --- a/Game/LambdaHack/Server/Fov.hs +++ b/Game/LambdaHack/Server/Fov.hs @@ -2,15 +2,11 @@ -- See -- for discussion. module Game.LambdaHack.Server.Fov - ( dungeonPerception, levelPerception - , fullscan, FovMode(..) + ( dungeonPerception, levelPerception, fullscan ) where -import Control.Arrow (second) -import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import qualified Data.List as L import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState @@ -22,8 +18,8 @@ import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Common.VectorXY import Game.LambdaHack.Content.ActorKind +import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Server.Fov.Common import qualified Game.LambdaHack.Server.Fov.Digital as Digital @@ -31,36 +27,41 @@ import qualified Game.LambdaHack.Server.Fov.Shadow as Shadow newtype PerceptionReachable = PerceptionReachable - { preachable :: ES.EnumSet Point } + {preachable :: [Point]} deriving Show -- | Calculate perception of the level. -levelPerception :: Kind.COps -> State -> FovMode -> FactionId - -> LevelId -> Level +levelPerception :: Kind.COps -> FovMode -> FactionId + -> LevelId -> Level -> State -> Perception -levelPerception cops@Kind.COps{cotile} s configFov fid lid lvl = - let hs = actorAssocs (== fid) lid s - reas = map (second $ computeReachable cops configFov lvl) hs - lreas = map (preachable . snd) reas - totalRea = PerceptionReachable $ ES.unions lreas +levelPerception cops@Kind.COps{cotile, coactor=Kind.Ops{okind}} + configFov fid lid lvl@Level{lxsize, lysize} s = + let hs = actorNotProjList (== fid) lid s + cR b = preachable $ computeReachable cops configFov lvl b + totalReachable = PerceptionReachable $ concatMap cR hs -- TODO: give actors light sources explicitly or alter vision. - lights = ES.fromList $ map (bpos . snd) hs - ptotal = computeVisible cotile totalRea lvl lights - g = PerceptionVisible . ES.intersection (pvisible ptotal) . preachable - perActor = EM.map g $ EM.fromList reas -- reas is not sorted - psmell = smellFromActors cops s perActor - in Perception {..} + pAndVicinity p = p : vicinity lxsize lysize p + lightsBodies = map (\b -> (pAndVicinity $ bpos b, b)) hs + light = concat $ map fst lightsBodies + ptotal = computeVisible cotile totalReachable lvl light + canSmell b = asmell $ okind $ bkind b + -- We assume smell FOV radius is always 1, regardless of vision + -- radius of the actor (if he can see at all). + psmell = PerceptionVisible $ ES.fromList + $ concat $ map fst $ filter (canSmell . snd) lightsBodies + in Perception ptotal psmell -- | Calculate perception of a faction. -factionPerception :: Kind.COps -> FovMode -> State -> FactionId +factionPerception :: Kind.COps -> FovMode -> FactionId -> State -> FactionPers -factionPerception cops configFov s fid = - EM.mapWithKey (levelPerception cops s configFov fid) $ sdungeon s +factionPerception cops configFov fid s = + EM.mapWithKey (\lid lvl -> levelPerception cops configFov fid lid lvl s) + $ sdungeon s -- | Calculate the perception of the whole dungeon. dungeonPerception :: Kind.COps -> FovMode -> State -> Pers dungeonPerception cops configFov s = - let f fid _ = factionPerception cops configFov s fid + let f fid _ = factionPerception cops configFov fid s in EM.mapWithKey f $ sfactionD s -- | A position can be directly lit by an ambient shine or a weak, portable @@ -78,24 +79,13 @@ -- there must be a wall in-between. Stray rays indicate doors, -- moving shadows indicate monsters, etc. computeVisible :: Kind.Ops TileKind -> PerceptionReachable - -> Level -> ES.EnumSet Point -> PerceptionVisible -computeVisible cotile reachable@PerceptionReachable{preachable} lvl lights = - let isV = isVisible cotile reachable lvl lights - in PerceptionVisible $ ES.filter isV preachable - --- TODO: this is calculated per-faction, not per-actor, but still optimize, --- e.g., by partitioning preachable wrt litDirectly and then running --- isVisible only over one of the parts, depending on which is smaller. -isVisible :: Kind.Ops TileKind -> PerceptionReachable - -> Level -> ES.EnumSet Point -> Point -> Bool -isVisible cotile PerceptionReachable{preachable} - lvl@Level{lxsize, lysize} lights pos0 = - let litDirectly pos = Tile.isLit cotile (lvl `at` pos) - || pos `ES.member` lights - l_and_R pos = litDirectly pos && pos `ES.member` preachable - in litDirectly pos0 || L.any l_and_R (vicinity lxsize lysize pos0) + -> Level -> [Point] -> PerceptionVisible +computeVisible cotile PerceptionReachable{preachable} lvl lights = + let isVisible pos = Tile.isLit cotile (lvl `at` pos) + in PerceptionVisible $ ES.fromList $ lights ++ filter isVisible preachable --- | Reachable are all fields on an unblocked path from the hero position. +-- | Reachable are all fields on a visually unblocked path +-- from the hero position. computeReachable :: Kind.COps -> FovMode -> Level -> Actor -> PerceptionReachable computeReachable Kind.COps{cotile, coactor=Kind.Ops{okind}} @@ -104,7 +94,7 @@ fovMode = if sight then configFov else Blind ppos = bpos body scan = fullscan cotile fovMode ppos lvl - in PerceptionReachable $ ES.fromList scan + in PerceptionReachable scan -- | Perform a full scan for a given position. Returns the positions -- that are currently in the field of view. The Field of View @@ -115,65 +105,45 @@ -> Point -- ^ position of the spectator -> Level -- ^ the map that is scanned -> [Point] -fullscan cotile fovMode spectatorPos Level{lxsize, ltile} = spectatorPos : +fullscan cotile fovMode spectatorPos lvl = spectatorPos : case fovMode of Shadow -> - L.concatMap (\ tr -> map tr (Shadow.scan (isCl . tr) 1 (0, 1))) tr8 + concatMap (\tr -> map tr (Shadow.scan (isCl . tr) 1 (0, 1))) tr8 Permissive -> - L.concatMap (\ tr -> map tr (Permissive.scan (isCl . tr))) tr4 + concatMap (\tr -> map tr (Permissive.scan (isCl . tr))) tr4 Digital r -> - L.concatMap (\ tr -> map tr (Digital.scan r (isCl . tr))) tr4 + concatMap (\tr -> map tr (Digital.scan r (isCl . tr))) tr4 Blind -> -- all actors feel adjacent positions (for easy exploration) let radiusOne = 1 - in L.concatMap (\ tr -> map tr (Digital.scan radiusOne (isCl . tr))) tr4 + in concatMap (\tr -> map tr (Digital.scan radiusOne (isCl . tr))) tr4 where isCl :: Point -> Bool - isCl = Tile.isClear cotile . (ltile Kind.!) + isCl = Tile.isClear cotile . (lvl `at`) - trV xy = shift spectatorPos $ toVector lxsize $ VectorXY xy + -- This function is cheap, so no problem it's called twice + -- for each point: once with @isCl@, once via @concatMap@. + trV :: X -> Y -> Point + {-# INLINE trV #-} + trV x y = shift spectatorPos $ Vector x y -- | The translation, rotation and symmetry functions for octants. tr8 :: [(Distance, Progress) -> Point] tr8 = - [ \ (p, d) -> trV ( p, d) - , \ (p, d) -> trV (- p, d) - , \ (p, d) -> trV ( p, - d) - , \ (p, d) -> trV (- p, - d) - , \ (p, d) -> trV ( d, p) - , \ (p, d) -> trV (- d, p) - , \ (p, d) -> trV ( d, - p) - , \ (p, d) -> trV (- d, - p) + [ \(p, d) -> trV p d + , \(p, d) -> trV (-p) d + , \(p, d) -> trV p (-d) + , \(p, d) -> trV (-p) (-d) + , \(p, d) -> trV d p + , \(p, d) -> trV (-d) p + , \(p, d) -> trV d (-p) + , \(p, d) -> trV (-d) (-p) ] -- | The translation and rotation functions for quadrants. tr4 :: [Bump -> Point] tr4 = - [ \ (B(x, y)) -> trV ( x, - y) -- quadrant I - , \ (B(x, y)) -> trV ( y, x) -- II (we rotate counter-clockwise) - , \ (B(x, y)) -> trV (- x, y) -- III - , \ (B(x, y)) -> trV (- y, - x) -- IV + [ \B{..} -> trV bx (-by) -- quadrant I + , \B{..} -> trV by bx -- II (we rotate counter-clockwise) + , \B{..} -> trV (-bx) by -- III + , \B{..} -> trV (-by) (-bx) -- IV ] - --- TODO: should Blind really be a FovMode, or a modifier? Let's decide --- when other similar modifiers are added. --- | Field Of View scanning mode. -data FovMode = - Shadow -- ^ restrictive shadow casting - | Permissive -- ^ permissive FOV - | Digital !Int -- ^ digital FOV with the given radius - | Blind -- ^ only feeling out adjacent tiles by touch - deriving (Show, Read) - -instance Binary FovMode where - put Shadow = putWord8 0 - put Permissive = putWord8 1 - put (Digital r) = putWord8 2 >> put r - put Blind = putWord8 3 - get = do - tag <- getWord8 - case tag of - 0 -> return Shadow - 1 -> return Permissive - 2 -> fmap Digital get - 3 -> return Blind - _ -> fail "no parse (FovMode)" diff --git a/Game/LambdaHack/Server/Fov/Common.hs b/Game/LambdaHack/Server/Fov/Common.hs --- a/Game/LambdaHack/Server/Fov/Common.hs +++ b/Game/LambdaHack/Server/Fov/Common.hs @@ -7,14 +7,12 @@ -- * Scanning coordinate system , Bump(..) -- * Geometry in system @Bump@ - , Line, ConvexHull, Edge, EdgeInterval + , Line(..), ConvexHull, Edge, EdgeInterval -- * Assorted minor operations , maximal, steeper, addHull ) where -import qualified Data.List as L - -import Game.LambdaHack.Common.PointXY +import Data.List -- | Distance from the (0, 0) point where FOV originates. type Distance = Int @@ -28,11 +26,16 @@ -- The special coordinates are written using the standard mathematical -- coordinate setup, where quadrant I, with x and y positive, -- is on the upper right. -newtype Bump = B (X, Y) - deriving (Show) +data Bump = B + { bx :: !Int + , by :: !Int + } + deriving Show -- | Straight line between points. -type Line = (Bump, Bump) +data Line = Line !Bump !Bump + deriving Show + -- | Convex hull represented as a list of points. type ConvexHull = [Bump] -- | An edge (comprising of a line and a convex hull) @@ -44,14 +47,16 @@ -- | Maximal element of a non-empty list. Prefers elements from the rear, -- which is essential for PFOV, to avoid ill-defined lines. maximal :: (a -> a -> Bool) -> [a] -> a -maximal gte = L.foldl1' (\ acc e -> if gte e acc then e else acc) +{-# INLINE maximal #-} +maximal gte = foldl1' (\acc e -> if gte e acc then e else acc) -- | Check if the line from the second point to the first is more steep -- than the line from the third point to the first. This is related -- to the formal notion of gradient (or angle), but hacked wrt signs -- to work fast in this particular setup. Returns True for ill-defined lines. steeper :: Bump -> Bump -> Bump -> Bool -steeper (B(xf, yf)) (B(x1, y1)) (B(x2, y2)) = +{-# INLINE steeper #-} +steeper (B xf yf) (B x1 y1) (B x2 y2) = (yf - y1)*(xf - x2) >= (yf - y2)*(xf - x1) -- | Extends a convex hull of bumps with a new bump. Nothing needs to be done @@ -61,6 +66,7 @@ -> Bump -- ^ a new bump to consider -> ConvexHull -- ^ a convex hull of bumps represented as a list -> ConvexHull +{-# INLINE addHull #-} addHull gte new = (new :) . go where go (a:b:cs) | gte a b = go (b:cs) diff --git a/Game/LambdaHack/Server/Fov/Digital.hs b/Game/LambdaHack/Server/Fov/Digital.hs --- a/Game/LambdaHack/Server/Fov/Digital.hs +++ b/Game/LambdaHack/Server/Fov/Digital.hs @@ -5,9 +5,10 @@ ( scan, dline, dsteeper, intersect, debugSteeper, debugLine ) where +import Control.Exception.Assert.Sugar + import Game.LambdaHack.Common.Misc import Game.LambdaHack.Server.Fov.Common -import Control.Exception.Assert.Sugar -- | Calculates the list of tiles, in @Bump@ coordinates, visible from (0, 0), -- within the given sight range. @@ -16,10 +17,13 @@ -> [Bump] scan r isClear = -- The scanned area is a square, which is a sphere in the chessboard metric. - dscan 1 (((B(1, 0), B(-r, r)), [B(0, 0)]), ((B(0, 0), B(r+1, r)), [B(1, 0)])) + dscan 1 ( (Line (B 1 0) (B (-r) r), [B 0 0]) + , (Line (B 0 0) (B (r+1) r), [B 1 0]) ) where dscan :: Distance -> EdgeInterval -> [Bump] - dscan d (s0@(sl{-shallow line-}, sBumps0), e@(el{-steep line-}, eBumps)) = + dscan d ( s0@(sl{-shallow line-}, sHull0) + , e@(el{-steep line-}, eHull) ) = + let ps0 = let (n, k) = intersect sl d -- minimal progress to consider in n `div` k pe = let (n, k) = intersect el d -- maximal progress to consider @@ -28,49 +32,53 @@ -- so if its intersection with the line of diagonals is only -- at a corner, choose the diamond leading to a smaller view. in -1 + n `divUp` k - inside = [B(p, d) | p <- [ps0..pe]] + inside = [B p d | p <- [ps0..pe]] outside | d >= r = [] - | isClear (B(ps0, d)) = mscan (Just s0) (ps0+1) pe -- start in light - | otherwise = mscan Nothing (ps0+1) pe -- start in shadow + | isClear (B ps0 d) = mscanVisible s0 (ps0+1) -- start visible + | otherwise = mscanShadowed (ps0+1) -- start in shadow + + -- We're in a visible interval. + mscanVisible :: Edge -> Progress -> [Bump] + mscanVisible s@(_, sHull) ps + | ps > pe = dscan (d+1) (s, e) -- reached end, scan next + | not $ isClear steepBump = -- entering shadow + mscanShadowed (ps+1) + ++ dscan (d+1) (s, (dline nep steepBump, neHull)) + | otherwise = mscanVisible s (ps+1) -- continue in visible area + where + steepBump = B ps d + gte = dsteeper steepBump + nep = maximal gte sHull + neHull = addHull gte steepBump eHull + + -- We're in a shadowed interval. + mscanShadowed :: Progress -> [Bump] + mscanShadowed ps + | ps > pe = [] -- reached end while in shadow + | isClear shallowBump = -- moving out of shadow + mscanVisible (dline nsp shallowBump, nsHull) (ps+1) + | otherwise = mscanShadowed (ps+1) -- continue in shadow + where + shallowBump = B ps d + gte = flip $ dsteeper shallowBump + nsp = maximal gte eHull + nsHull = addHull gte shallowBump sHull0 + in assert (r >= d && d >= 0 && pe >= ps0 `blame` (r,d,s0,e,ps0,pe)) $ inside ++ outside - where - -- The current state of a scan is kept in @Maybe Edge@. - -- If it's the @Just@ case, we're in a visible interval. If @Nothing@, - -- we're in a shadowed interval. - mscan :: Maybe Edge -> Progress -> Progress -> [Bump] - mscan (Just s@(_, sBumps)) ps pe - | ps > pe = dscan (d+1) (s, e) -- reached end, scan next - | not $ isClear steepBump = -- entering shadow - mscan Nothing (ps+1) pe - ++ dscan (d+1) (s, (dline nep steepBump, neBumps)) - | otherwise = mscan (Just s) (ps+1) pe -- continue in light - where - steepBump = B(ps, d) - gte = dsteeper steepBump - nep = maximal gte sBumps - neBumps = addHull gte steepBump eBumps - mscan Nothing ps pe - | ps > pe = [] -- reached end while in shadow - | isClear shallowBump = -- moving out of shadow - mscan (Just (dline nsp shallowBump, nsBumps)) (ps+1) pe - | otherwise = mscan Nothing (ps+1) pe -- continue in shadow - where - shallowBump = B(ps, d) - gte = flip $ dsteeper shallowBump - nsp = maximal gte eBumps - nsBumps = addHull gte shallowBump sBumps0 - -- | Create a line from two points. Debug: check if well-defined. dline :: Bump -> Bump -> Line +{-# INLINE dline #-} dline p1 p2 = - assert (uncurry blame $ debugLine (p1, p2)) (p1, p2) + let line = Line p1 p2 + in assert (uncurry blame $ debugLine line) line -- | Compare steepness of @(p1, f)@ and @(p2, f)@. -- Debug: Verify that the results of 2 independent checks are equal. dsteeper :: Bump -> Bump -> Bump -> Bool +{-# INLINE dsteeper #-} dsteeper f p1 p2 = assert (res == debugSteeper f p1 p2) res where res = steeper f p1 p2 @@ -79,7 +87,8 @@ -- a given line and the line of diagonals of diamonds at distance -- @d@ from (0, 0). intersect :: Line -> Distance -> (Int, Int) -intersect (B(x, y), B(xf, yf)) d = +{-# INLINE intersect #-} +intersect (Line (B x y) (B xf yf)) d = assert (allB (>= 0) [y, yf]) ((d - y)*(xf - x) + x*(yf - y), yf - y) {- @@ -115,15 +124,17 @@ -- | Debug: calculate steeper for DFOV in another way and compare results. debugSteeper :: Bump -> Bump -> Bump -> Bool -debugSteeper f@(B(_xf, yf)) p1@(B(_x1, y1)) p2@(B(_x2, y2)) = +{-# INLINE debugSteeper #-} +debugSteeper f@(B _xf yf) p1@(B _x1 y1) p2@(B _x2 y2) = assert (allB (>= 0) [yf, y1, y2]) $ - let (n1, k1) = intersect (p1, f) 0 - (n2, k2) = intersect (p2, f) 0 + let (n1, k1) = intersect (Line p1 f) 0 + (n2, k2) = intersect (Line p2 f) 0 in n1 * k2 >= k1 * n2 -- | Debug: check if a view border line for DFOV is legal. debugLine :: Line -> (Bool, String) -debugLine line@(B(x1, y1), B(x2, y2)) +{-# INLINE debugLine #-} +debugLine line@(Line (B x1 y1) (B x2 y2)) | not (allB (>= 0) [y1, y2]) = (False, "negative coordinates: " ++ show line) | y1 == y2 && x1 == x2 = diff --git a/Game/LambdaHack/Server/Fov/Permissive.hs b/Game/LambdaHack/Server/Fov/Permissive.hs --- a/Game/LambdaHack/Server/Fov/Permissive.hs +++ b/Game/LambdaHack/Server/Fov/Permissive.hs @@ -7,9 +7,10 @@ ( scan, dline, dsteeper, intersect, debugSteeper, debugLine ) where +import Control.Exception.Assert.Sugar + import Game.LambdaHack.Common.Misc import Game.LambdaHack.Server.Fov.Common -import Control.Exception.Assert.Sugar -- TODO: Scanning squares on horizontal lines in octants, not squares -- on diagonals in quadrants, may be much faster and a bit simpler. @@ -20,10 +21,12 @@ scan :: (Bump -> Bool) -- ^ clear tile predicate -> [Bump] scan isClear = - dscan 1 (((B(0, 1), B(999, 0)), [B(1, 0)]), ((B(1, 0), B(0, 999)), [B(0, 1)])) + dscan 1 ( (Line (B 0 1) (B 999 0), [B 1 0]) + , (Line (B 1 0) (B 0 999), [B 0 1]) ) where dscan :: Distance -> EdgeInterval -> [Bump] - dscan d (s0@(sl{-shallow line-}, sBumps0), e@(el{-steep line-}, eBumps)) = + dscan d ( s0@(sl{-shallow line-}, sHull0) + , e@(el{-steep line-}, eHull) ) = assert (d >= 0 && pe + 1 >= ps0 && ps0 >= 0 `blame` (d,s0,e,ps0,pe)) $ if illegal then [] else inside ++ outside @@ -36,46 +39,47 @@ -- A single ray from an extremity produces non-permissive digital lines. illegal = let (n, k) = intersect sl 0 in ns*ke == ne*ks && (n `elem` [0, k]) - pd2bump (p, di) = B(di - p , p) - bottomRight (p, di) = B(di - p + 1, p) + pd2bump (p, di) = B (di - p) p + bottomRight (p, di) = B (di - p + 1) p inside = [pd2bump (p, d) | p <- [ps0..pe]] outside - | isClear (pd2bump (ps0, d)) = mscan (Just s0) ps0 -- start in light - | ps0 == ns `divUp` ks = mscan (Just s0) ps0 -- start in a corner - | otherwise = mscan Nothing (ps0+1) -- start in mid-wall + | isClear (pd2bump (ps0, d)) = mscanVisible s0 ps0 -- start visible + | ps0 == ns `divUp` ks = mscanVisible s0 ps0 -- start in a corner + | otherwise = mscanShadowed (ps0+1) -- start in mid-wall - -- The current state of a scan is kept in @Maybe Edge@. - -- If it's the @Just@ case, we're in a visible interval. If @Nothing@, - -- we're in a shadowed interval. - mscan :: Maybe Edge -> Progress -> [Bump] - mscan (Just s@(_, sBumps)) ps + -- We're in a visible interval. + mscanVisible :: Edge -> Progress -> [Bump] + mscanVisible s@(_, sHull) ps | ps > pe = dscan (d+1) (s, e) -- reached end, scan next | not $ isClear (pd2bump (ps, d)) = -- enter shadow, steep bump let steepBump = bottomRight (ps, d) gte = flip $ dsteeper steepBump - -- sBumps may contain steepBump, but maximal will ignore it - nep = maximal gte sBumps - neBumps = addHull gte steepBump eBumps - in mscan Nothing (ps+1) - ++ dscan (d+1) (s, (dline nep steepBump, neBumps)) - | otherwise = mscan (Just s) (ps+1) -- continue in light + -- sHull may contain steepBump, but maximal will ignore it + nep = maximal gte sHull + neHull = addHull gte steepBump eHull + in mscanShadowed (ps+1) + ++ dscan (d+1) (s, (dline nep steepBump, neHull)) + | otherwise = mscanVisible s (ps+1) -- continue in visible area - mscan Nothing ps + -- we're in a shadowed interval. + mscanShadowed :: Progress -> [Bump] + mscanShadowed ps | ps > ne `div` ke = [] -- reached absolute end | otherwise = -- out of shadow, shallow bump - -- the light can be just through a corner of diagonal walls + -- the ray can just pass through a corner of diagonal walls -- and the recursive call verifies that at the same ps coordinate let shallowBump = bottomRight (ps, d) gte = dsteeper shallowBump - nsp = maximal gte eBumps - nsBumps = addHull gte shallowBump sBumps0 - in mscan (Just (dline nsp shallowBump, nsBumps)) ps + nsp = maximal gte eHull + nsHull = addHull gte shallowBump sHull0 + in mscanVisible (dline nsp shallowBump, nsHull) ps -- | Create a line from two points. Debug: check if well-defined. dline :: Bump -> Bump -> Line dline p1 p2 = - assert (uncurry blame $ debugLine (p1, p2)) (p1, p2) + let line = Line p1 p2 + in assert (uncurry blame $ debugLine line) line -- | Compare steepness of @(p1, f)@ and @(p2, f)@. -- Debug: Verify that the results of 2 independent checks are equal. @@ -88,7 +92,7 @@ -- a given line and the line of diagonals of squares at distance -- @d@ from (0, 0). intersect :: Line -> Distance -> (Int, Int) -intersect (B(x, y), B(xf, yf)) d = +intersect (Line (B x y) (B xf yf)) d = assert (allB (>= 0) [x, y, xf, yf]) ((1 + d)*(yf - y) + y*xf - x*yf, (xf - x) + (yf - y)) {- @@ -125,15 +129,15 @@ -- | Debug: calculate steeper for PFOV in another way and compare results. debugSteeper :: Bump -> Bump -> Bump -> Bool -debugSteeper f@(B(xf, yf)) p1@(B(x1, y1)) p2@(B(x2, y2)) = +debugSteeper f@(B xf yf) p1@(B x1 y1) p2@(B x2 y2) = assert (allB (>= 0) [xf, yf, x1, y1, x2, y2]) $ - let (n1, k1) = intersect (p1, f) 0 - (n2, k2) = intersect (p2, f) 0 + let (n1, k1) = intersect (Line p1 f) 0 + (n2, k2) = intersect (Line p2 f) 0 in n1 * k2 <= k1 * n2 -- | Debug: checks postconditions of borderLine. debugLine :: Line -> (Bool, String) -debugLine line@(B(x1, y1), B(x2, y2)) +debugLine line@(Line (B x1 y1) (B x2 y2)) | not (allB (>= 0) [x1, y1, x2, y2]) = (False, "negative coordinates: " ++ show line) | y1 == y2 && x1 == x2 = diff --git a/Game/LambdaHack/Server/Fov/Shadow.hs b/Game/LambdaHack/Server/Fov/Shadow.hs --- a/Game/LambdaHack/Server/Fov/Shadow.hs +++ b/Game/LambdaHack/Server/Fov/Shadow.hs @@ -4,10 +4,10 @@ -- The main advantage of the algorithm is that it's very simple and fast. module Game.LambdaHack.Server.Fov.Shadow (SBump, Interval, scan) where +import Control.Exception.Assert.Sugar import Data.Ratio import Game.LambdaHack.Server.Fov.Common -import Control.Exception.Assert.Sugar {- Field Of View diff --git a/Game/LambdaHack/Server/LoopAction.hs b/Game/LambdaHack/Server/LoopAction.hs --- a/Game/LambdaHack/Server/LoopAction.hs +++ b/Game/LambdaHack/Server/LoopAction.hs @@ -3,16 +3,15 @@ module Game.LambdaHack.Server.LoopAction (loopSer) where import Control.Arrow ((&&&)) +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Key (mapWithKeyM_) import Data.List import Data.Maybe import qualified Data.Ord as Ord +import Data.Text (Text) -import Control.Exception.Assert.Sugar -import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState @@ -31,16 +30,16 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ActorKind -import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Frontend import Game.LambdaHack.Server.Action hiding (sendUpdateAI, sendUpdateUI) -import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.EffectSem import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.ServerSem import Game.LambdaHack.Server.StartAction import Game.LambdaHack.Server.State +import Game.LambdaHack.Utils.Frequency -- | Start a game session. Loop, communicating with clients. loopSer :: (MonadAtomic m, MonadConnServer m) @@ -48,7 +47,7 @@ -> (CmdSer -> m Bool) -> (FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer -> IO ()) - -> (FactionId -> ChanServer CmdClientAI CmdSerTakeTime + -> (FactionId -> ChanServer CmdClientAI CmdTakeTimeSer -> IO ()) -> Kind.COps -> m () @@ -61,7 +60,7 @@ let setPreviousCops = const cops execCmdAtomic $ ResumeServerA $ updateCOps setPreviousCops sRaw putServer ser - sdebugNxt <- initDebug sdebug + sdebugNxt <- initDebug cops sdebug modifyServer $ \ser2 -> ser2 {sdebugNxt} applyDebug updateConn executorUI executorAI @@ -72,21 +71,22 @@ let setCurrentCops = const (speedupCOps (sallClear sdebugNxt) cops) -- @sRaw@ is correct here, because none of the above changes State. execCmdAtomic $ ResumeServerA $ updateCOps setCurrentCops sRaw - initPer _ -> do -- Starting a new game. -- Set up commandline debug mode let mrandom = case restored of Just (_, ser) -> Just $ srandom ser Nothing -> Nothing s <- gameReset cops sdebug mrandom - sdebugNxt <- initDebug sdebug - modifyServer $ \ser -> ser {sdebugNxt, sdebugSer = sdebugNxt} + sdebugNxt <- initDebug cops sdebug + let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing} + modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs + , sdebugSer = debugBarRngs } let speedup = speedupCOps (sallClear sdebugNxt) execCmdAtomic $ RestartServerA $ updateCOps speedup s updateConn executorUI executorAI initPer reinitGame - when (sdumpConfig sdebug) $ void $ dumpCfg + when (sdumpInitRngs sdebug) $ dumpRngs resetSessionStart -- Start a clip (a part of a turn for which one or more frames -- will be generated). Do whatever has to be done @@ -101,7 +101,7 @@ Just leader -> do b <- getsState $ getActorBody leader return $ Just $ blid b - _ -> return Nothing + Nothing -> return Nothing factionD <- getsState sfactionD marenas <- mapM factionArena $ EM.elems factionD let arenas = ES.toList $ ES.fromList $ catMaybes marenas @@ -118,34 +118,23 @@ when continue loop loop -initDebug :: MonadServer m => DebugModeSer -> m DebugModeSer -initDebug sdebugSer = do - sconfig <- getsServer sconfig - return $ +initDebug :: MonadActionRO m => Kind.COps -> DebugModeSer -> m DebugModeSer +initDebug Kind.COps{corule} sdebugSer = do + let stdRuleset = Kind.stdRuleset corule + return $! (\dbg -> dbg {sfovMode = - sfovMode dbg `mplus` Just (configFovMode sconfig)}) . + sfovMode dbg `mplus` Just (rfovMode stdRuleset)}) . (\dbg -> dbg {ssavePrefixSer = - ssavePrefixSer dbg `mplus` Just (configSavePrefix sconfig)}) + ssavePrefixSer dbg `mplus` Just (rsavePrefix stdRuleset)}) $ sdebugSer --- This can be improved by adding a timeout and by asking clients to prepare --- a save (in this way checking they have permissions, enough space, etc.) --- and when all report back, asking them to commit the save. --- | Save game on server and all clients. Clients are pinged first, --- which greatly reduced the chance of saves being out of sync. -saveBkpAll :: (MonadAtomic m, MonadServer m, MonadConnServer m) => m () -saveBkpAll = do - factionD <- getsState sfactionD - let ping fid _ = do - sendPingAI fid - when (playerUI $ gplayer $ factionD EM.! fid) $ sendPingUI fid - mapWithKeyM_ ping factionD - execCmdAtomic SaveBkpA - saveServer - endClip :: (MonadAtomic m, MonadServer m, MonadConnServer m) => [LevelId] -> m Bool endClip arenas = do + Kind.COps{corule} <- getsState scops + let stdRuleset = Kind.stdRuleset corule + saveBkpClips = rsaveBkpClips stdRuleset + leadLevelClips = rleadLevelClips stdRuleset -- TODO: a couple messages each clip to many clients is too costly. -- Store these on a queue and sum times instead of sending, -- until a different command needs to be sent. Include HealActorA @@ -155,15 +144,15 @@ execCmdAtomic $ AgeGameA timeClip -- Perform periodic dungeon maintenance. time <- getsState stime - Config{configSaveBkpClips} <- getsServer sconfig let clipN = time `timeFit` timeClip - cinT = let r = timeTurn `timeFit` timeClip - in assert (r > 2) r - clipMod = clipN `mod` cinT + clipInTurn = let r = timeTurn `timeFit` timeClip + in assert (r > 2) r + clipMod = clipN `mod` clipInTurn bkpSave <- getsServer sbkpSave - when (bkpSave || clipN `mod` configSaveBkpClips == 0) $ do + when (bkpSave || clipN `mod` saveBkpClips == 0) $ do modifyServer $ \ser -> ser {sbkpSave = False} - saveBkpAll + saveBkpAll False + when (clipN `mod` leadLevelClips == 0) leadLevelFlip -- Regenerate HP and add monsters each turn, not each clip. -- Do this on only one of the arenas to prevent micromanagement, -- e.g., spreading leaders across levels to bump monster generation. @@ -171,12 +160,13 @@ arena <- rndToAction $ oneOf arenas regenerateLevelHP arena generateMonster arena - sstopAfter <- getsServer $ sstopAfter . sdebugSer - case sstopAfter of + stopAfter <- getsServer $ sstopAfter . sdebugSer + case stopAfter of Nothing -> return True - Just stopAfter -> do - exit <- elapsedSessionTimeGT stopAfter + Just stopA -> do + exit <- elapsedSessionTimeGT stopA if exit then do + tellAllClipPS saveAndExit return False -- don't re-enter the game loop else return True @@ -192,7 +182,6 @@ -> LevelId -> m () handleActors cmdSerSem lid = do - Kind.COps{cofaction=Kind.Ops{okind}} <- getsState scops time <- getsState $ getLocalTime lid -- the end of this clip, inclusive Level{lprio} <- getLevel lid quit <- getsServer squit @@ -212,28 +201,34 @@ case mnext of _ | quit -> return () Nothing -> return () - Just (aid, b) | bproj b && bhp b < 0 -> do + Just (aid, b) | bhp b < 0 && bproj b -> do -- A projectile hits an actor. The carried item is destroyed. - -- TODO: perhaps don't destroy if no effect (NoEffect). - ais <- getsState $ getActorItem aid - execCmdAtomic $ DestroyActorA aid b ais + -- TODO: perhaps don't destroy if no effect (NoEffect), + -- to help testing items. But OTOH, we want most items to have + -- some effect, even silly, for flavour. Anyway, if the silly + -- effect identifies an item, the hit is not wasted, so this makes sense. + dieSer aid b True -- The attack animation for the projectile hit subsumes @DisplayPushD@, -- so not sending an extra @DisplayPushD@ here. handleActors cmdSerSem lid - Just (aid, b) | bhp b <= 0 && not (bproj b) - || maybe False null (bpath b) -> do - -- An actor (projectile or not) ceases to exist. - -- Items drop to the ground and possibly a new leader is elected. - dieSer aid - -- If it's a death, not a projectile drop, the death animation - -- subsumes @DisplayPushD@, so not sending it here. ProjectileProjectile - -- destruction is not important enough for an extra @DisplayPushD@. + Just (aid, b) | maybe False null (btrajectory b) -> do + assert (bproj b) skip + execSfxAtomic $ DisplayPushD (bfid b) -- show last position before drop + -- A projectile drops to the ground due to obstacles or range. + dieSer aid b False handleActors cmdSerSem lid + Just (aid, b) | bhp b <= 0 && not (bproj b) -> do + -- An actor dies. Items drop to the ground + -- and possibly a new leader is elected. + dieSer aid b False + -- The death animation subsumes @DisplayPushD@, so not sending it here. + handleActors cmdSerSem lid Just (aid, body) -> do let side = bfid body fact = factionD EM.! side mleader = gleader fact - queryUI | Just aid == mleader = not $ playerAiLeader $ gplayer fact + aidIsLeader = mleader == Just aid + queryUI | aidIsLeader = not $ playerAiLeader $ gplayer fact | otherwise = not $ playerAiOther $ gplayer fact switchLeader cmdS = do -- TODO: check that the command is legal first, report and reject, @@ -245,9 +240,11 @@ then -- Only a leader can change his faction's leader -- before the action is performed (e.g., via AI -- switching leaders). Then, the action can change - -- the leader again (e.g., via using stairs). - assert (mleader == Just aid && not (bproj bPre) - `blame` (aid, aidNew, bPre, cmdS, fact)) + -- the leader again (e.g., via killing the old leader). + assert (aidIsLeader + && not (bproj bPre) + && not (isSpawnFact fact) + `blame` (aid, body, aidNew, bPre, cmdS, fact)) [LeadFactionA side mleader (Just aidNew)] else [] mapM_ execCmdAtomic leadAtoms @@ -255,6 +252,12 @@ `blame` "client tries to move other faction actors" `twith` (bPre, side)) skip return (aidNew, bPre) + setBWait (CmdTakeTimeSer WaitSer{}) aidNew bPre = do + let fromWait = bwait bPre + unless fromWait $ execCmdAtomic $ WaitActorA aidNew fromWait True + setBWait _ aidNew bPre = do + let fromWait = bwait bPre + when fromWait $ execCmdAtomic $ WaitActorA aidNew fromWait False extraFrames bPre = do -- Generate extra frames if the actor has already moved during -- this clip, so his multiple moves would be collapsed @@ -265,7 +268,22 @@ lastSingleMove = timeAddFromSpeed bPre previousClipEnd when (btime bPre > lastSingleMove) $ broadcastSfxAtomic DisplayPushD - if queryUI then do + if bproj body then do -- TODO: perhaps check Track, not bproj + execSfxAtomic $ DisplayPushD side + let cmdS = CmdTakeTimeSer $ SetTrajectorySer aid + timed <- cmdSerSem cmdS + assert timed skip + b <- getsState $ getActorBody aid + -- Colliding with a wall or actor doesn't take time, because + -- the projectile does not move (the move is blocked). + -- Not advancing time forces dead projectiles to be destroyed ASAP. + -- Otherwise it would be displayed in the same place twice. + -- If ever needed this can be implemented properly by moving + -- SetTrajectorySer out of CmdTakeTimeSer. + unless (bhp b < 0 || maybe False null (btrajectory b)) $ do + advanceTime aid + extraFrames b + else if queryUI then do -- The client always displays a frame in this case. cmdS <- sendQueryUI side aid (aidNew, bPre) <- switchLeader cmdS @@ -275,6 +293,7 @@ $ MsgFidD side "You strain, fumble and faint from the exertion." return False else cmdSerSem cmdS + setBWait cmdS aidNew bPre -- Advance time once, after the leader switched perhaps many times. -- TODO: this is correct only when all heroes have the same -- speed and can't switch leaders by, e.g., aiming a wand @@ -292,54 +311,112 @@ -- but one by one. execSfxAtomic $ DisplayPushD side -- Clear messages in the UI client (if any), if the actor - -- is freely moving. - let factionAbilities - | Just aid == mleader = fAbilityLeader $ okind $ gkind fact - | otherwise = fAbilityOther $ okind $ gkind fact - canMove = playerUI (gplayer fact) - && not (bproj body) - && (Ability.Chase `elem` factionAbilities - || Ability.Wander `elem` factionAbilities) - when canMove $ execSfxAtomic $ RecordHistoryD side - cmdT <- sendQueryAI side aid - let cmdS = TakeTimeSer cmdT + -- is a leader (which happens when a UI client is fully + -- computer-controlled). We could record history more often, + -- to avoid long reports, but we'd have to add -more- prompts. + let mainUIactor = playerUI (gplayer fact) && aidIsLeader + when mainUIactor $ execSfxAtomic $ RecordHistoryD side + cmdTimed <- sendQueryAI side aid + let cmdS = CmdTakeTimeSer cmdTimed (aidNew, bPre) <- switchLeader cmdS assert (not (bhp bPre <= 0 && not (bproj bPre)) `blame` "AI switches to an incapacitated actor" `twith` (cmdS, bPre, side)) skip - void $ cmdSerSem cmdS + timed <- cmdSerSem cmdS + assert timed skip + setBWait cmdS aidNew bPre -- AI always takes time and so doesn't loop. advanceTime aidNew extraFrames bPre handleActors cmdSerSem lid -dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> m () -dieSer aid = do -- TODO: explode if a projectile holding a potion - body <- getsState $ getActorBody aid +dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> Bool -> m () +dieSer aid b hit = do -- TODO: clients don't see the death of their last standing actor; -- modify Draw.hs and Client.hs to handle that - electLeader (bfid body) (blid body) aid - dropAllItems aid body - execCmdAtomic $ DestroyActorA aid body {bbag = EM.empty} [] - deduceKilled body + if bproj b then do + dropAllItems aid b hit + b2 <- getsState $ getActorBody aid + execCmdAtomic $ DestroyActorA aid b2 [] + else do + electLeader (bfid b) (blid b) aid + deduceKilled b + dropAllItems aid b False + b2 <- getsState $ getActorBody aid + execCmdAtomic $ DestroyActorA aid b2 [] --- | Drop all actor's items. -dropAllItems :: MonadAtomic m => ActorId -> Actor -> m () -dropAllItems aid b = do - let f iid k = execCmdAtomic - $ MoveItemA iid k (actorContainer aid (binv b) iid) - (CFloor (blid b) (bpos b)) +-- | Drop all actor's items. If the actor hits another actor and this +-- collision results in all item being dropped, all items are destroyed. +-- If the actor does not hit, but dies, only fragile items are destroyed +-- and only if the actor was a projectile (and so died by dropping +-- to the ground due to exceeded range or bumping off an obstacle). +dropAllItems :: (MonadAtomic m, MonadServer m) + => ActorId -> Actor -> Bool -> m () +dropAllItems aid b hit = do + Kind.COps{coitem} <- getsState scops + discoS <- getsServer sdisco + let isDestroyed item = hit || bproj b && isFragile coitem discoS item + f iid k = do + let container = actorContainer aid (binv b) iid + item <- getsState $ getItemBody iid + if isDestroyed item then + case isExplosive coitem discoS item of + Nothing -> execCmdAtomic $ DestroyItemA iid item k container + Just cgroup -> do + let ik = fromJust $ jkind discoS item + execCmdAtomic $ DiscoverA (blid b) (bpos b) iid ik + execCmdAtomic $ DestroyItemA iid item k container + explodeItem aid b container cgroup + else + execCmdAtomic $ MoveItemA iid k container (CFloor (blid b) (bpos b)) mapActorItems_ f b +explodeItem :: (MonadAtomic m, MonadServer m) + => ActorId -> Actor -> Container -> Text -> m () +explodeItem aid b container cgroup = do + Kind.COps{coitem} <- getsState scops + flavour <- getsServer sflavour + discoRev <- getsServer sdiscoRev + Level{ldepth} <- getLevel $ blid b + depth <- getsState sdepth + let itemFreq = toFreq "shrapnel group" [(1, cgroup)] + (item, n1, _) <- rndToAction + $ newItem coitem flavour discoRev itemFreq ldepth depth + iid <- registerItem item n1 container False + let Point x y = bpos b + projectN n = replicateM_ n $ do + tpxy <- rndToAction $ do + border <- randomR (1, 4) + -- We pick a point at the border, not inside, to have a uniform + -- distribution for the points the line goes through at each distance + -- from the source. Otherwise, e.g., the points on cardinal + -- and diagonal lines from the source would be more common. + case border :: Int of + 1 -> fmap (Point (x - 10)) $ randomR (y - 10, y + 10) + 2 -> fmap (Point (x + 10)) $ randomR (y - 10, y + 10) + 3 -> fmap (flip Point (y - 10)) $ randomR (x - 10, x + 10) + 4 -> fmap (flip Point (y + 10)) $ randomR (x - 10, x + 10) + _ -> assert `failure` border + let eps = px tpxy + py tpxy + mfail <- projectFail aid tpxy eps iid container True + case mfail of + Nothing -> return () + Just ProjectBlockTerrain -> return () + Just failMsg -> execFailure aid failMsg + projectN n1 + bag2 <- getsState $ bbag . getActorBody aid + let mn2 = EM.lookup iid bag2 + maybe skip projectN mn2 -- assume all shrapnels bounce off obstacles once + bag3 <- getsState $ bbag . getActorBody aid + let mn3 = EM.lookup iid bag3 + maybe skip (\k -> execCmdAtomic $ LoseItemA iid item k container) mn3 + -- | Advance the move time for the given actor. advanceTime :: MonadAtomic m => ActorId -> m () advanceTime aid = do b <- getsState $ getActorBody aid - -- Don't update move time, so move ASAP, so the projectile - -- corpse vanishes ASAP. - unless (bhp b < 0 && bproj b || maybe False null (bpath b)) $ do - let t = ticksPerMeter $ bspeed b - execCmdAtomic $ AgeActorA aid t + let t = ticksPerMeter $ bspeed b + execCmdAtomic $ AgeActorA aid t -- | Generate a monster, possibly. generateMonster :: (MonadAtomic m, MonadServer m) => LevelId -> m () @@ -352,9 +429,15 @@ spawns = actorNotProjList f lid s depth <- getsState sdepth rc <- rndToAction $ monsterGenChance ldepth depth (length spawns) + factionD <- getsState sfactionD when rc $ do time <- getsState $ getLocalTime lid - mfid <- pickFaction "spawn" (const True) + let freq = toFreq "spawn" + $ map (\(fid, fact) -> (playerSpawn $ gplayer fact, fid)) + $ EM.assocs factionD + mfid <- if nullFreq freq then + return Nothing + else fmap Just $ rndToAction $ frequency freq case mfid of Nothing -> return () -- no faction spawns Just fid -> do @@ -373,9 +456,9 @@ as = actorList (const True) lid s isLit = Tile.isLit cotile distantAtLeast d p _ = - all (\b -> chessDist lxsize (bpos b) p > d) inhabitants + all (\b -> chessDist (bpos b) p > d) inhabitants findPosTry 40 ltile - ( \p t -> Tile.hasFeature cotile F.Walkable t + ( \p t -> Tile.isWalkable cotile t && unoccupied as p) [ \_ t -> not (isLit t) -- no such tiles on some maps , distantAtLeast factionDist @@ -394,7 +477,7 @@ -- thing, but immediately (and destroy the item). -- | Possibly regenerate HP for all actors on the current level. -- --- We really want leader selection to be a purely UI distinction, +-- We really want leader picking to be a purely UI distinction, -- so all actors need to regenerate, not just the leaders. -- Actors on frozen levels don't regenerate. This prevents cheating -- via sending an actor to a safe level and letting him regenerate there. @@ -418,10 +501,54 @@ || bhp m <= 0 then Nothing else Just a - toRegen <- - getsState $ mapMaybe approve . actorNotProjAssocs (const True) lid + toRegen <- getsState $ mapMaybe approve . actorNotProjAssocs (const True) lid mapM_ (\aid -> execCmdAtomic $ HealActorA aid 1) toRegen +leadLevelFlip :: (MonadAtomic m, MonadServer m) => m () +leadLevelFlip = do + Kind.COps{cotile} <- getsState scops + let canFlip fact = playerAiLeader (gplayer fact) + || isSpawnFact fact + flipFaction fact | not $ canFlip fact = return () + flipFaction fact = do + case gleader fact of + Nothing -> return () + Just leader -> do + body <- getsState $ getActorBody leader + lvl2 <- getLevel $ blid body + let leaderStuck = waitedLastTurn body + t = lvl2 `at` bpos body + -- Keep the leader: he is on stairs and not stuck + -- and we don't want to clog stairs or get pushed to another level. + unless (not leaderStuck && Tile.isStair cotile t) $ do + actorD <- getsState sactorD + let ourLvl (lid, lvl) = + ( lid + , EM.size (lfloor lvl) + , actorNotProjAssocsLvl (== bfid body) lvl actorD ) + ours <- getsState $ map ourLvl . EM.assocs . sdungeon + -- Non-humans, being born in the dungeon, have a rough idea of + -- the number of items left on the level and will focus + -- on levels they started exploring and that have few items + -- left. This is to to explore them completely, leave them + -- once and for all and concentrate forces on another level. + -- In addition, sole stranded actors tend to become leaders + -- so that they can join the main force ASAP. + let freqList = [ (k, (lid, a)) + | (lid, itemN, (a, b) : rest) <- ours + , bhp b > 0 -- drama levels skipped + , not leaderStuck || lid /= blid body + , let len = 1 + (min 10 $ length rest) + k = 1000000 `div` (3 * itemN + len) ] + unless (null freqList) $ do + (lid, a) <- rndToAction $ frequency + $ toFreq "leadLevel" freqList + unless (lid == blid body) $ + execCmdAtomic + $ LeadFactionA (bfid body) (Just leader) (Just a) + factionD <- getsState sfactionD + mapM_ flipFaction $ EM.elems factionD + -- | Continue or exit or restart the game. endOrLoop :: (MonadAtomic m, MonadConnServer m) => m () -> m () -> m () endOrLoop updConn loopServer = do @@ -444,8 +571,8 @@ modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {sgameMode}} restartGame updConn loopServer _ | gameOver -> restartGame updConn loopServer - (_, []) -> loopServer -- continue current game - (_, _ : _) -> do + ([], []) -> loopServer -- continue current game + ([], _ : _) -> do -- Wipe out the quit flag for the savegame files. mapM_ (\(fid, fact) -> execCmdAtomic @@ -458,7 +585,7 @@ saveAndExit = do cops <- getsState scops -- Save client and server data. - saveBkpAll + saveBkpAll True -- debugPrint "Server saves game before exit" -- Kill all clients, including those that did not take part -- in the current game. @@ -476,11 +603,14 @@ restartGame :: (MonadAtomic m, MonadConnServer m) => m () -> m () -> m () restartGame updConn loopServer = do + tellGameClipPS cops <- getsState scops sdebugNxt <- getsServer sdebugNxt srandom <- getsServer srandom s <- gameReset cops sdebugNxt $ Just srandom - modifyServer $ \ser -> ser {sdebugNxt, sdebugSer = sdebugNxt} + let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing} + modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs + , sdebugSer = debugBarRngs } execCmdAtomic $ RestartServerA s updConn initPer diff --git a/Game/LambdaHack/Server/ServerSem.hs b/Game/LambdaHack/Server/ServerSem.hs --- a/Game/LambdaHack/Server/ServerSem.hs +++ b/Game/LambdaHack/Server/ServerSem.hs @@ -9,6 +9,7 @@ -- TODO: document module Game.LambdaHack.Server.ServerSem where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM import Data.Key (mapWithKeyM_) @@ -17,12 +18,13 @@ import Data.Text (Text) import qualified NLP.Miniutter.English as MU -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Animation import Game.LambdaHack.Common.AtomicCmd import qualified Game.LambdaHack.Common.Color as Color +import Game.LambdaHack.Common.Effect import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Item @@ -45,15 +47,18 @@ import Game.LambdaHack.Server.State execFailure :: (MonadAtomic m, MonadServer m) - => Actor -> FailureSer -> m () -execFailure body failureSer = do + => ActorId -> FailureSer -> m () +execFailure aid failureSer = do -- Clients should rarely do that (only in case of invisible actors) -- so we report it, send a --more-- meeesage (if not AI), but do not crash -- (server should work OK with stupid clients, too). + body <- getsState $ getActorBody aid let fid = bfid body msg = showFailureSer failureSer - debugPrint $ "execFailure:" <+> showT fid <+> ":" <+> msg - execSfxAtomic $ MsgFidD fid msg -- TODO: --more-- + debugPrint + $ "execFailure:" <+> tshow fid <+> ":" <+> msg <> "\n" <> tshow body + execSfxAtomic $ MsgFidD fid $ "Unexpected problem:" <+> msg <> "." + -- TODO: --more--, but keep in history broadcastCmdAtomic :: MonadAtomic m => (FactionId -> CmdAtomic) -> m () @@ -69,21 +74,16 @@ -- * MoveSer -checkAdjacent :: MonadActionRO m => Actor -> Actor -> m Bool -checkAdjacent sb tb = do - Level{lxsize} <- getLevel $ blid sb - return $ blid sb == blid tb && adjacent lxsize (bpos sb) (bpos tb) - -- TODO: let only some actors/items leave smell, e.g., a Smelly Hide Armour. --- | Add a smell trace for the actor to the level. For now, all and only --- actors from non-spawning factions leave smell. +-- | Add a smell trace for the actor to the level. For now, only heroes +-- leave smell. addSmell :: MonadAtomic m => ActorId -> m () addSmell aid = do - Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops + cops@Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops b <- getsState $ getActorBody aid - spawn <- getsState $ isSpawnFaction (bfid b) + fact <- getsState $ (EM.! bfid b) . sfactionD let canSmell = asmell $ okind $ bkind b - unless (bproj b || spawn || canSmell) $ do + unless (bproj b || not (isHeroFact cops fact) || canSmell) $ do time <- getsState $ getLocalTime $ blid b lvl <- getLevel $ blid b let oldS = EM.lookup (bpos b) . lsmell $ lvl @@ -107,17 +107,18 @@ -- We start by checking actors at the the target position. tgt <- getsState $ posToActor tpos lid case tgt of - Just target -> -- visible or not + Just ((target, tb), _) | not (bproj sb && bproj tb) -> -- visible or not -- Attacking does not require full access, adjacency is enough. + -- Projectiles are too small to hit each other. meleeSer source target - Nothing + _ | accessible cops lvl spos tpos -> do -- Movement requires full access. execCmdAtomic $ MoveActorA source spos tpos addSmell source | otherwise -> -- Client foolishly tries to move into blocked, boring tile. - execFailure sb MoveNothing + execFailure source MoveNothing -- * MeleeSer @@ -126,17 +127,20 @@ -- For instance, an actor embedded in a wall can be attacked from -- an adjacent position. This function is analogous to projectGroupItem, -- but for melee and not using up the weapon. +-- No problem if there are many projectiles at the spot. We just +-- attack the one specified. meleeSer :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m () meleeSer source target = do - cops@Kind.COps{coitem=Kind.Ops{opick, okind}} <- getsState scops + cops@Kind.COps{coitem=coitem@Kind.Ops{opick, okind}} <- getsState scops sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target - adj <- checkAdjacent sb tb - if not adj then execFailure sb MeleeDistant + let adj = checkAdjacent sb tb + if source == target then execFailure source MeleeSelf + else if not adj then execFailure source MeleeDistant else do let sfid = bfid sb tfid = bfid tb - time <- getsState $ getLocalTime (blid tb) + sfact <- getsState $ (EM.! sfid) . sfactionD itemAssocs <- getsState $ getActorItem source (miid, item) <- if bproj sb -- projectile @@ -146,15 +150,18 @@ else case strongestSword cops itemAssocs of Just (_, (iid, w)) -> return (Just iid, w) -- weapon combat Nothing -> do -- hand to hand combat - isSp <- getsState $ isSpawnFaction sfid - let h2hGroup | isSp = "monstrous" - | otherwise = "unarmed" + let isHero = isHeroFact cops sfact + h2hGroup | isHero = "unarmed" + | otherwise = "monstrous" h2hKind <- rndToAction $ fmap (fromMaybe $ assert `failure` h2hGroup) $ opick h2hGroup (const True) flavour <- getsServer sflavour discoRev <- getsServer sdiscoRev let kind = okind h2hKind - effect = fmap maxDeep (ieffect kind) + let kindEffect = case causeIEffects coitem h2hKind of + [] -> NoEffect + eff : _TODO -> eff + effect = fmap maxDeep kindEffect return ( Nothing , buildItem flavour discoRev h2hKind kind effect ) let performHit block = do @@ -162,18 +169,17 @@ execSfxAtomic $ StrikeD source target item hitA -- Deduct a hitpoint for a pierce of a projectile. when (bproj sb) $ execCmdAtomic $ HealActorA source (-1) - -- Msgs inside itemEffectSem describe the target part. + -- Msgs inside itemEffect describe the target part. itemEffect source target miid item -- Projectiles can't be blocked (though can be sidestepped). -- Incapacitated actors can't block. - if braced tb time && not (bproj sb) && bhp tb > 0 + if braced tb && not (bproj sb) && bhp tb > 0 then do blocked <- rndToAction $ chance $ 1%2 if blocked then execSfxAtomic $ StrikeD source target item MissBlockD else performHit True else performHit False - sfact <- getsState $ (EM.! sfid) . sfactionD -- The only way to start a war is to slap an enemy. Being hit by -- and hitting projectiles count as unintentional friendly fire. let friendlyFire = bproj sb || bproj tb @@ -189,20 +195,26 @@ cops <- getsState scops sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target - adj <- checkAdjacent sb tb - if not adj then execFailure sb DisplaceDistant + let adj = checkAdjacent sb tb + if not adj then execFailure source DisplaceDistant else do let lid = blid sb lvl <- getLevel lid let spos = bpos sb tpos = bpos tb + -- Displacing requires full access. if accessible cops lvl spos tpos then do - -- Displacing requires full access. - execCmdAtomic $ DisplaceActorA source target - addSmell source + tgts <- getsState $ posToActors tpos lid + case tgts of + [] -> assert `failure` (source, sb, target, tb) + [_] -> do + execCmdAtomic $ DisplaceActorA source target + addSmell source + addSmell target + _ -> execFailure source DisplaceProjectiles else do -- Client foolishly tries to displace an actor without access. - execFailure sb DisplaceAccess + execFailure source DisplaceAccess -- * AlterSer @@ -217,8 +229,7 @@ sb <- getsState $ getActorBody source let lid = blid sb spos = bpos sb - Level{lxsize} <- getLevel lid - if not $ adjacent lxsize spos tpos then execFailure sb AlterDistant + if not $ adjacent spos tpos then execFailure source AlterDistant else do lvl <- getLevel lid let serverTile = lvl `at` tpos @@ -243,7 +254,7 @@ as <- getsState $ actorList (const True) lid if null groupsToAlter && serverTile == freshClientTile then -- Neither searching nor altering possible; silly client. - execFailure sb AlterNothing + execFailure source AlterNothing else do if EM.null $ lvl `atI` tpos then if unoccupied as tpos then do @@ -254,86 +265,111 @@ mapM_ changeTo groupsToAlter -- Perform an effect, if any permitted. void $ triggerEffect source feats - else execFailure sb AlterBlockActor - else execFailure sb AlterBlockItem + else execFailure source AlterBlockActor + else execFailure source AlterBlockItem -- * WaitSer --- | Update the wait/block count. Uses local, per-level time, --- to remain correct even if the level is frozen for some global time turns. +-- | Do nothing. +-- +-- Something is sometimes done in 'LoopAction.setBWait'. waitSer :: MonadAtomic m => ActorId -> m () -waitSer aid = do - body <- getsState $ getActorBody aid - time <- getsState $ getLocalTime $ blid body - let fromWait = bwait body - toWait = timeAddFromSpeed body time - execCmdAtomic $ WaitActorA aid fromWait toWait +waitSer _ = return () -- * PickupSer -pickupSer :: MonadAtomic m - => ActorId -> ItemId -> Int -> InvChar -> m () -pickupSer aid iid k l = assert (k > 0 `blame` "pick up no items" - `twith` (aid, iid, k, l)) $ do +pickupSer :: (MonadAtomic m, MonadServer m) + => ActorId -> ItemId -> Int -> m () +pickupSer aid iid k = assert (k > 0) $ do b <- getsState $ getActorBody aid - execCmdAtomic $ MoveItemA iid k (CFloor (blid b) (bpos b)) (CActor aid l) + item <- getsState $ getItemBody iid + case actorContainerB aid b iid item of + Just c -> execCmdAtomic $ MoveItemA iid k (CFloor (blid b) (bpos b)) c + Nothing -> execFailure aid PickupOverfull -- * DropSer -dropSer :: MonadAtomic m => ActorId -> ItemId -> m () -dropSer aid iid = do +dropSer :: MonadAtomic m => ActorId -> ItemId -> Int -> m () +dropSer aid iid k = assert (k > 0) $ do b <- getsState $ getActorBody aid - let k = 1 - execCmdAtomic $ MoveItemA iid k (actorContainer aid (binv b) iid) - (CFloor (blid b) (bpos b)) + let c = actorContainer aid (binv b) iid + execCmdAtomic $ MoveItemA iid k c (CFloor (blid b) (bpos b)) -- * ProjectSer projectSer :: (MonadAtomic m, MonadServer m) => ActorId -- ^ actor projecting the item (is on current lvl) - -> Point -- ^ target position of the projectile + -> Point -- ^ target position of the projectile -> Int -- ^ digital line parameter -> ItemId -- ^ the item to be projected -> Container -- ^ whether the items comes from floor or inventory -> m () -projectSer source tpos eps iid container = do - Kind.COps{cotile} <- getsState scops +projectSer source tpxy eps iid container = do + mfail <- projectFail source tpxy eps iid container False + maybe skip (execFailure source) mfail + +projectFail :: (MonadAtomic m, MonadServer m) + => ActorId -- ^ actor projecting the item (is on current lvl) + -> Point -- ^ target position of the projectile + -> Int -- ^ digital line parameter + -> ItemId -- ^ the item to be projected + -> Container -- ^ whether the items comes from floor or inventory + -> Bool -- ^ whether the item is a shrapnel + -> m (Maybe FailureSer) +projectFail source tpxy eps iid container isShrapnel = do + Kind.COps{coactor=Kind.Ops{okind}, cotile} <- getsState scops sb <- getsState $ getActorBody source let lid = blid sb spos = bpos sb - fact <- getsState $ (EM.! bfid sb) . sfactionD - Level{lxsize, lysize} <- getLevel lid - foes <- getsState $ actorNotProjList (isAtWar fact) lid - if foesAdjacent lxsize lysize spos foes - then execFailure sb ProjectBlockFoes - else do - case bla lxsize lysize eps spos tpos of - Nothing -> execFailure sb ProjectAimOnself - Just [] -> assert `failure` "projecting from the edge of level" - `twith` (spos, tpos) - Just (pos : rest) -> do - as <- getsState $ actorList (const True) lid - lvl <- getLevel lid - let t = lvl `at` pos - if not $ Tile.hasFeature cotile F.Clear t - then execFailure sb ProjectBlockTerrain - else if unoccupied as pos - then projectBla source pos rest iid container - else execFailure sb ProjectBlockActor + lvl@Level{lxsize, lysize} <- getLevel lid + case bla lxsize lysize eps spos tpxy of + Nothing -> return $ Just ProjectAimOnself + Just [] -> assert `failure` "projecting from the edge of level" + `twith` (spos, tpxy) + Just (pos : rest) -> do + let t = lvl `at` pos + if not $ Tile.isClear cotile t + then return $ Just ProjectBlockTerrain + else do + mab <- getsState $ posToActor pos lid + if not $ maybe True (bproj . snd . fst) mab + then + if isShrapnel then do + -- Hit the blocking actor. + projectBla source spos (pos : rest) iid container + return Nothing + else return $ Just ProjectBlockActor + else do + blockedByFoes <- + if isShrapnel then return False + else do + fact <- getsState $ (EM.! bfid sb) . sfactionD + foes <- getsState $ actorNotProjList (isAtWar fact) lid + return $! foesAdjacent lxsize lysize spos foes + if blockedByFoes then + return $ Just ProjectBlockFoes + else if not (asight (okind $ bkind sb) || bproj sb) + then return $ Just ProjectBlind + else do + if isShrapnel && eps `mod` 2 == 0 then + -- Make the explosion a bit less regular. + projectBla source spos (pos:rest) iid container + else + projectBla source pos rest iid container + return Nothing projectBla :: (MonadAtomic m, MonadServer m) => ActorId -- ^ actor projecting the item (is on current lvl) -> Point -- ^ starting point of the projectile - -> [Point] -- ^ rest of the path of the projectile + -> [Point] -- ^ rest of the trajectory of the projectile -> ItemId -- ^ the item to be projected -> Container -- ^ whether the items comes from floor or inventory -> m () projectBla source pos rest iid container = do sb <- getsState $ getActorBody source let lid = blid sb - -- A bit later than actor time, to prevent a move this turn. - time = btime sb `timeAdd` timeEpsilon - execSfxAtomic $ ProjectD source iid + time = btime sb + unless (bproj sb) $ execSfxAtomic $ ProjectD source iid projId <- addProjectile pos rest iid lid (bfid sb) time execCmdAtomic $ MoveItemA iid 1 container (CActor projId (InvChar 'a')) @@ -346,23 +382,25 @@ , coitem=coitem@Kind.Ops{okind=iokind} } <- getsState scops disco <- getsServer sdisco item <- getsState $ getItemBody iid - let ik = iokind (fromJust $ jkind disco item) - speed = speedFromWeight (iweight ik) (itoThrow ik) + let lingerPercent = isLingering coitem disco item + ik = iokind (fromJust $ jkind disco item) + speed = speedFromWeight (jweight item) (itoThrow ik) range = rangeFromSpeed speed adj | range < 5 = "falling" | otherwise = "flying" -- Not much details about a fast flying object. (object1, object2) = partItem coitem EM.empty item name = makePhrase [MU.AW $ MU.Text adj, object1, object2] - dirPath = take range $ displacePath (bpos : rest) + trajectoryLength = lingerPercent * range `div` 100 + dirTrajectory = take trajectoryLength $ pathToTrajectory (bpos : rest) kind = okind $ projectileKindId coactor m = actorTemplate (projectileKindId coactor) (asymbol kind) name - (acolor kind) speed 0 (Just dirPath) + (acolor kind) speed 0 (Just dirTrajectory) bpos blid btime bfid True acounter <- getsServer sacounter modifyServer $ \ser -> ser {sacounter = succ acounter} execCmdAtomic $ CreateActorA acounter m [(iid, item)] - return acounter + return $! acounter -- * ApplySer @@ -396,7 +434,7 @@ Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2] Just _ -> [] go <- triggerEffect aid feats - unless go $ execFailure sb TriggerNothing + unless go $ execFailure aid TriggerNothing triggerEffect :: (MonadAtomic m, MonadServer m) => ActorId -> [F.Feature] -> m Bool @@ -414,39 +452,60 @@ goes <- mapM triggerFeat feats return $! or goes --- * SetPathSer +-- * SetTrajectorySer -setPathSer :: (MonadAtomic m, MonadServer m) - => ActorId -> [Vector] -> m () -setPathSer aid path = do - when (length path <= 2) $ do - fromColor <- getsState $ bcolor . getActorBody aid - let toColor = Color.BrBlack - when (fromColor /= toColor) $ - execCmdAtomic $ ColorActorA aid fromColor toColor - fromPath <- getsState $ bpath . getActorBody aid - case path of - [] -> execCmdAtomic $ PathActorA aid fromPath (Just []) - d : lv -> do - void $ moveSer aid d - execCmdAtomic $ PathActorA aid fromPath (Just lv) +setTrajectorySer :: (MonadAtomic m, MonadServer m) => ActorId -> m () +setTrajectorySer aid = do + cops <- getsState scops + b@Actor{bpos, btrajectory, blid, bcolor} <- getsState $ getActorBody aid + lvl <- getLevel blid + let clearTrajectory = + execCmdAtomic $ TrajectoryActorA aid btrajectory (Just []) + case btrajectory of + Just (d : lv) -> + if not $ accessibleDir cops lvl bpos d + then clearTrajectory + else do + when (length lv <= 1) $ do + let toColor = Color.BrBlack + when (bcolor /= toColor) $ + execCmdAtomic $ ColorActorA aid bcolor toColor + moveSer aid d + execCmdAtomic $ TrajectoryActorA aid btrajectory (Just lv) + _ -> assert `failure` "null trajectory" `twith` (aid, b) -- * GameRestart -gameRestartSer :: (MonadAtomic m, MonadServer m) => ActorId -> Text -> m () -gameRestartSer aid stInfo = do +-- TODO: implement a handshake and send hero names there, +-- so that they are available in the first game too, +-- not only in subsequent, restarted, games. +gameRestartSer :: (MonadAtomic m, MonadServer m) + => ActorId -> Text -> Int -> [(Int, Text)] -> m () +gameRestartSer aid stInfo d configHeroNames = do + modifyServer $ \ser -> + ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d + , sdebugCli = (sdebugCli (sdebugNxt ser)) + {sdifficultyCli = d} + }} b <- getsState $ getActorBody aid let fid = bfid b oldSt <- getsState $ gquit . (EM.! fid) . sfactionD - modifyServer $ \ser -> ser {squit = True} -- do this at once + modifyServer $ \ser -> + ser { squit = True -- do this at once + , sheroNames = EM.insert fid configHeroNames $ sheroNames ser } revealItems Nothing Nothing execCmdAtomic $ QuitFactionA fid (Just b) oldSt $ Just $ Status Restart (fromEnum $ blid b) stInfo -- * GameExit -gameExitSer :: (MonadAtomic m, MonadServer m) => ActorId -> m () -gameExitSer aid = do +gameExitSer :: (MonadAtomic m, MonadServer m) => ActorId -> Int -> m () +gameExitSer aid d = do + modifyServer $ \ser -> + ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d + , sdebugCli = (sdebugCli (sdebugNxt ser)) + {sdifficultyCli = d} + }} b <- getsState $ getActorBody aid let fid = bfid b oldSt <- getsState $ gquit . (EM.! fid) . sfactionD diff --git a/Game/LambdaHack/Server/StartAction.hs b/Game/LambdaHack/Server/StartAction.hs --- a/Game/LambdaHack/Server/StartAction.hs +++ b/Game/LambdaHack/Server/StartAction.hs @@ -1,8 +1,9 @@ -- | Operations for starting and restarting the game. module Game.LambdaHack.Server.StartAction - ( applyDebug, gameReset, reinitGame, initPer + ( applyDebug, gameReset, reinitGame, saveBkpAll, initPer ) where +import Control.Exception.Assert.Sugar import Control.Monad import qualified Control.Monad.State as St import qualified Data.Char as Char @@ -17,7 +18,6 @@ import Data.Tuple (swap) import qualified System.Random as R -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.AtomicCmd @@ -25,21 +25,21 @@ import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Flavour +import qualified Game.LambdaHack.Common.HighScore as HighScore import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Server.Action hiding (sendUpdateAI, sendUpdateUI) -import Game.LambdaHack.Server.Config import qualified Game.LambdaHack.Server.DungeonGen as DungeonGen import Game.LambdaHack.Server.EffectSem import Game.LambdaHack.Server.Fov @@ -58,7 +58,7 @@ , sstopAfter , sdbgMsgSer , snewGameSer - , sdumpConfig + , sdumpInitRngs , sdebugCli }} initPer :: MonadServer m => m () @@ -68,9 +68,9 @@ pers <- getsState $ dungeonPerception cops (fromMaybe (Digital 12) fovMode) modifyServer $ \ser1 -> ser1 {sper = pers} -reinitGame :: (MonadAtomic m, MonadServer m) => m () +reinitGame :: (MonadAtomic m, MonadConnServer m) => m () reinitGame = do - Kind.COps{ coitem=Kind.Ops{okind}, corule } <- getsState scops + Kind.COps{coitem=Kind.Ops{okind}, corule} <- getsState scops pers <- getsServer sper knowMap <- getsServer $ sknowMap . sdebugSer -- This state is quite small, fit for transmition to the client. @@ -89,7 +89,26 @@ broadcastCmdAtomic $ \fid -> RestartA fid sdisco (pers EM.! fid) defLoc sdebugCli modeName populateDungeon + saveBkpAll False +-- TODO: This can be improved by adding a timeout +-- and by asking clients to prepare +-- a save (in this way checking they have permissions, enough space, etc.) +-- and when all report back, asking them to commit the save. +-- | Save game on server and all clients. Clients are pinged first, +-- which greatly reduced the chance of saves being out of sync. +saveBkpAll :: (MonadAtomic m, MonadServer m, MonadConnServer m) => Bool -> m () +saveBkpAll unconditional = do + factionD <- getsState sfactionD + let ping fid _ = do + sendPingAI fid + when (playerUI $ gplayer $ factionD EM.! fid) $ sendPingUI fid + mapWithKeyM_ ping factionD + bench <- getsServer $ sbenchmark . sdebugSer + when (unconditional || not bench) $ do + execCmdAtomic SaveBkpA + saveServer + mapFromInvFuns :: (Bounded a, Enum a, Ord b) => [a -> b] -> M.Map b a mapFromInvFuns = let fromFun f m1 = @@ -117,7 +136,7 @@ let gdipl = EM.empty -- fixed below gquit = Nothing gleader = Nothing - return Faction{..} + return $! Faction{..} lUI <- mapM rawCreate $ filter playerUI $ playersList players lnoUI <- mapM rawCreate $ filter (not . playerUI) $ playersList players let lFs = reverse (zip [toEnum (-1), toEnum (-2)..] lnoUI) -- sorted @@ -142,18 +161,21 @@ -- War overrides alliance, so 'warFs' second. allianceFs = mkDipl Alliance rawFs (swapIx (playersAlly players)) warFs = mkDipl War allianceFs (swapIx (playersEnemy players)) - return warFs + return $! warFs gameReset :: MonadServer m => Kind.COps -> DebugModeSer -> Maybe R.StdGen -> m State -gameReset cops@Kind.COps{coitem, comode=Kind.Ops{opick, okind}, corule} +gameReset cops@Kind.COps{coitem, comode=Kind.Ops{opick, okind}} sdebug mrandom = do - -- Rules config reloaded at each new game start. - -- Taking the original config from config file, to reroll RNG, if needed - -- (the current config file has the RNG rolled for the previous game). - (sconfig, dungeonSeed, srandom) <- mkConfigRules corule mrandom - scoreTable <- restoreScore sconfig + dungeonSeed <- getSetGen $ sdungeonRng sdebug `mplus` mrandom + srandom <- getSetGen $ smainRng sdebug `mplus` mrandom + scoreTable <- if sbenchmark sdebug then + return HighScore.empty + else + restoreScore cops sstart <- getsServer sstart -- copy over from previous game + sallTime <- getsServer sallTime -- copy over from previous game + sheroNames <- getsServer sheroNames -- copy over from previous game let smode = sgameMode sdebug rnd :: Rnd (FactionDict, FlavourMap, Discovery, DiscoRev, DungeonGen.FreshDungeon) @@ -169,10 +191,13 @@ let (faction, sflavour, sdisco, sdiscoRev, DungeonGen.FreshDungeon{..}) = St.evalState rnd dungeonSeed defState = defStateGlobal freshDungeon freshDepth faction cops scoreTable - defSer = emptyStateServer - {sdisco, sdiscoRev, sflavour, srandom, sconfig, sstart} + defSer = emptyStateServer { sstart, sallTime, sheroNames, srandom + , srngs = RNGs (Just dungeonSeed) + (Just srandom) } putServer defSer - return defState + when (sbenchmark sdebug) resetGameStart + modifyServer $ \ser -> ser {sdisco, sdiscoRev, sflavour} + return $! defState -- Spawn initial actors. Clients should notice this, to set their leaders. populateDungeon :: (MonadAtomic m, MonadServer m) => m () @@ -192,7 +217,7 @@ dungeon <- getsState sdungeon mapWithKeyM_ initialItems dungeon factionD <- getsState sfactionD - Config{configHeroNames} <- getsServer sconfig + sheroNames <- getsServer sheroNames let (minD, maxD) = case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) @@ -218,10 +243,11 @@ psFree <- getsState $ nearbyFreePoints cotile validTile ppos lid let ps = take (playerInitial $ gplayer fact) $ zip [0..] psFree forM_ ps $ \ (n, p) -> - if isSpawnFact cops fact + if not $ isHeroFact cops fact then spawnMonsters [p] lid ntime side else do - aid <- addHero side p lid configHeroNames (Just n) ntime + let hNames = fromMaybe [] $ EM.lookup side sheroNames + aid <- addHero side p lid hNames (Just n) ntime mleader <- getsState $ gleader . (EM.! side) . sfactionD -- just changed when (isNothing mleader) $ @@ -233,7 +259,7 @@ findEntryPoss :: Kind.COps -> Level -> Int -> Rnd [Point] findEntryPoss Kind.COps{cotile} Level{ltile, lxsize, lysize, lstair} k = do let factionDist = max lxsize lysize - 5 - dist poss cmin l _ = all (\pos -> chessDist lxsize l pos > cmin) poss + dist poss cmin l _ = all (\pos -> chessDist l pos > cmin) poss tryFind _ 0 = return [] tryFind ps n = do np <- findPosTry 1000 ltile -- try really hard, for skirmish fairness @@ -245,9 +271,9 @@ , dist ps $ factionDist `div` 16 ] nps <- tryFind (np : ps) (n - 1) - return $ np : nps + return $! np : nps stairPoss = fst lstair ++ snd lstair - middlePos = toPoint lxsize $ PointXY (lxsize `div` 2, lysize `div` 2) + middlePos = Point (lxsize `div` 2) (lysize `div` 2) assert (k > 0 && factionDist > 0) skip case k of 1 -> tryFind stairPoss k diff --git a/Game/LambdaHack/Server/State.hs b/Game/LambdaHack/Server/State.hs --- a/Game/LambdaHack/Server/State.hs +++ b/Game/LambdaHack/Server/State.hs @@ -2,11 +2,13 @@ module Game.LambdaHack.Server.State ( StateServer(..), emptyStateServer , DebugModeSer(..), defDebugModeSer + , RNGs(..) ) where import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.HashMap.Strict as HM +import Data.List import Data.Text (Text) import qualified System.Random as R import System.Time @@ -14,28 +16,33 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Animation import Game.LambdaHack.Common.AtomicCmd +import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Server.Config -import Game.LambdaHack.Server.Fov +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.RuleKind -- | Global, server state. data StateServer = StateServer - { sdisco :: !Discovery -- ^ full item discoveries data - , sdiscoRev :: !DiscoRev -- ^ reverse disco map, used for item creation - , sitemRev :: !ItemRev -- ^ reverse id map, used for item creation - , sflavour :: !FlavourMap -- ^ association of flavour to items - , sacounter :: !ActorId -- ^ stores next actor index - , sicounter :: !ItemId -- ^ stores next item index - , sundo :: ![Atomic] -- ^ atomic commands performed to date - , sper :: !Pers -- ^ perception of all factions - , srandom :: !R.StdGen -- ^ current random generator - , sconfig :: Config -- ^ this game's config (including initial RNG) - , squit :: !Bool -- ^ exit the game loop - , sbkpSave :: !Bool -- ^ make backup savefile now - , sstart :: !ClockTime -- ^ this session start time - , sdebugSer :: !DebugModeSer -- ^ current debugging mode - , sdebugNxt :: !DebugModeSer -- ^ debugging mode for the next game + { sdisco :: !Discovery -- ^ full item discoveries data + , sdiscoRev :: !DiscoRev -- ^ reverse disco map, used for item creation + , sitemRev :: !ItemRev -- ^ reverse id map, used for item creation + , sflavour :: !FlavourMap -- ^ association of flavour to items + , sacounter :: !ActorId -- ^ stores next actor index + , sicounter :: !ItemId -- ^ stores next item index + , sundo :: ![Atomic] -- ^ atomic commands performed to date + , sper :: !Pers -- ^ perception of all factions + , srandom :: !R.StdGen -- ^ current random generator + , srngs :: !RNGs -- ^ initial random generators + , squit :: !Bool -- ^ exit the game loop + , sbkpSave :: !Bool -- ^ make backup savefile now + , sstart :: !ClockTime -- ^ this session start time + , sgstart :: !ClockTime -- ^ this game start time + , sallTime :: !Time -- ^ clips since the start of the session + , sheroNames :: !(EM.EnumMap FactionId [(Int, Text)]) + -- ^ hero names sent by clients + , sdebugSer :: !DebugModeSer -- ^ current debugging mode + , sdebugNxt :: !DebugModeSer -- ^ debugging mode for the next game } deriving (Show) @@ -48,15 +55,32 @@ , sallClear :: !Bool , sgameMode :: !Text , sstopAfter :: !(Maybe Int) + , sbenchmark :: !Bool + , sdungeonRng :: !(Maybe R.StdGen) + , smainRng :: !(Maybe R.StdGen) , sfovMode :: !(Maybe FovMode) , snewGameSer :: !Bool - , sdumpConfig :: !Bool + , sdifficultySer :: !Int + , sdumpInitRngs :: !Bool , ssavePrefixSer :: !(Maybe String) , sdbgMsgSer :: !Bool , sdebugCli :: !DebugModeCli } deriving Show +data RNGs = RNGs + { dungeonRandomGenerator :: !(Maybe R.StdGen) + , startingRandomGenerator :: !(Maybe R.StdGen) + } + +instance Show RNGs where + show RNGs{..} = + let args = [ maybe "" (\gen -> "--setDungeonRng \"" ++ show gen ++ "\"") + dungeonRandomGenerator + , maybe "" (\gen -> "--setMainRng \"" ++ show gen ++ "\"") + startingRandomGenerator ] + in intercalate " " args + -- | Initial, empty game server state. emptyStateServer :: StateServer emptyStateServer = @@ -70,10 +94,14 @@ , sundo = [] , sper = EM.empty , srandom = R.mkStdGen 42 - , sconfig = undefined + , srngs = RNGs { dungeonRandomGenerator = Nothing + , startingRandomGenerator = Nothing } , squit = False , sbkpSave = False , sstart = TOD 0 0 + , sgstart = TOD 0 0 + , sallTime = timeZero + , sheroNames = EM.empty , sdebugSer = defDebugModeSer , sdebugNxt = defDebugModeSer } @@ -86,9 +114,13 @@ , sallClear = False , sgameMode = "campaign" , sstopAfter = Nothing + , sbenchmark = False + , sdungeonRng = Nothing + , smainRng = Nothing , sfovMode = Nothing , snewGameSer = False - , sdumpConfig = False + , sdifficultySer = 0 + , sdumpInitRngs = False , ssavePrefixSer = Nothing , sdbgMsgSer = False , sdebugCli = defDebugModeCli @@ -104,7 +136,8 @@ put sicounter put sundo put (show srandom) - put sconfig + put srngs + put sheroNames put sdebugSer get = do sdisco <- get @@ -115,15 +148,18 @@ sicounter <- get sundo <- get g <- get - sconfig <- get + srngs <- get + sheroNames <- get sdebugSer <- get let srandom = read g sper = EM.empty squit = False sbkpSave = False sstart = TOD 0 0 - sdebugNxt = defDebugModeSer - return StateServer{..} + sgstart = TOD 0 0 + sallTime = timeZero + sdebugNxt = defDebugModeSer -- TODO: here difficulty level, etc. from the last session is wiped out + return $! StateServer{..} instance Binary DebugModeSer where put DebugModeSer{..} = do @@ -133,6 +169,7 @@ put sniffOut put sallClear put sgameMode + put sdifficultySer put sfovMode put ssavePrefixSer put sdbgMsgSer @@ -144,11 +181,26 @@ sniffOut <- get sallClear <- get sgameMode <- get + sdifficultySer <- get sfovMode <- get ssavePrefixSer <- get sdbgMsgSer <- get sdebugCli <- get let sstopAfter = Nothing + sbenchmark = False + sdungeonRng = Nothing + smainRng = Nothing snewGameSer = False - sdumpConfig = False - return DebugModeSer{..} + sdumpInitRngs = False + return $! DebugModeSer{..} + +instance Binary RNGs where + put RNGs{..} = do + put (show dungeonRandomGenerator) + put (show startingRandomGenerator) + get = do + dg <- get + sg <- get + let dungeonRandomGenerator = read dg + startingRandomGenerator = read sg + return $! RNGs{..} diff --git a/Game/LambdaHack/Utils/File.hs b/Game/LambdaHack/Utils/File.hs --- a/Game/LambdaHack/Utils/File.hs +++ b/Game/LambdaHack/Utils/File.hs @@ -1,20 +1,32 @@ -- | Saving/loading with serialization and compression. module Game.LambdaHack.Utils.File - ( encodeEOF, strictDecodeEOF, tryCreateDir, tryCopyDataFiles + ( encodeEOF, strictDecodeEOF, tryCreateDir, tryCopyDataFiles, appDataDir ) where import qualified Codec.Compression.Zlib as Z +import qualified Control.Exception as Ex import Control.Monad import Data.Binary import qualified Data.ByteString.Lazy as LBS +import qualified Data.Char as Char import System.Directory +import System.Environment import System.FilePath import System.IO -- | Serialize, compress and save data. -- Note that LBS.writeFile opens the file in binary mode. encodeData :: Binary a => FilePath -> a -> IO () -encodeData f = LBS.writeFile f . Z.compress . encode +encodeData f a = do + let tmpPath = f <.> "tmp" + Ex.bracketOnError + (openBinaryFile tmpPath WriteMode) + (\h -> hClose h >> removeFile tmpPath) + (\h -> do + LBS.hPut h . Z.compress . encode $ a + hClose h + renameFile tmpPath f + ) -- | Serialize, compress and save data with an EOF marker. -- The @OK@ is used as an EOF marker to ensure any apparent problems with @@ -41,7 +53,7 @@ strictDecodeEOF f = do (a, n) <- strictDecodeData f if n == ("OK" :: String) - then return a + then return $! a else error $ "Fatal error: corrupted file " ++ f -- | Try to create a directory, if it doesn't exist. Terminate the program @@ -56,11 +68,19 @@ -> (FilePath -> IO FilePath) -> [(FilePath, FilePath)] -> IO () -tryCopyDataFiles configAppDataDir pathsDataFile files = +tryCopyDataFiles dataDir pathsDataFile files = let cpFile (fin, fout) = do - pathsDataIn <- pathsDataFile $ takeFileName fin + pathsDataIn <- pathsDataFile fin bIn <- doesFileExist pathsDataIn - let pathsDataOut = configAppDataDir fout + let pathsDataOut = dataDir fout bOut <- doesFileExist pathsDataOut when (not bOut && bIn) $ copyFile pathsDataIn pathsDataOut in mapM_ cpFile files + +-- | Personal data directory for the game. Depends on the OS and the game, +-- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@. +appDataDir :: IO FilePath +appDataDir = do + progName <- getProgName + let name = takeWhile Char.isAlphaNum progName + getAppUserDataDirectory name diff --git a/Game/LambdaHack/Utils/Frequency.hs b/Game/LambdaHack/Utils/Frequency.hs --- a/Game/LambdaHack/Utils/Frequency.hs +++ b/Game/LambdaHack/Utils/Frequency.hs @@ -13,6 +13,7 @@ import Control.Applicative import Control.Arrow (first, second) +import Control.Exception.Assert.Sugar import Control.Monad import Data.Binary import Data.Foldable (Foldable) @@ -20,7 +21,6 @@ import Data.Traversable (Traversable) import qualified System.Random as R -import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Msg -- TODO: do not expose runFrequency @@ -32,6 +32,7 @@ deriving (Show, Eq, Foldable, Traversable) instance Monad Frequency where + {-# INLINE return #-} return x = Frequency "return" [(1, x)] Frequency name xs >>= f = Frequency ("bind (" <> name <> ")") @@ -42,8 +43,8 @@ fmap f (Frequency name xs) = Frequency name (map (second f) xs) instance Applicative Frequency where - pure = return - (<*>) = ap + pure = return + (<*>) = ap instance MonadPlus Frequency where mplus (Frequency xname xs) (Frequency yname ys) = @@ -56,8 +57,8 @@ mzero = Frequency "[]" [] instance Alternative Frequency where - (<|>) = mplus - empty = mzero + (<|>) = mplus + empty = mzero -- | Uniform discrete frequency distribution. uniformFreq :: Text -> [a] -> Frequency a @@ -116,4 +117,4 @@ get = do nameFrequency <- get runFrequency <- get - return Frequency{..} + return $! Frequency{..} diff --git a/GameDefinition/Content/ActorKind.hs b/GameDefinition/Content/ActorKind.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Content/ActorKind.hs @@ -0,0 +1,88 @@ +-- | Monsters and heroes for LambdaHack. +module Content.ActorKind ( cdefs ) where + +import Game.LambdaHack.Common.Ability +import Game.LambdaHack.Common.Color +import Game.LambdaHack.Common.ContentDef +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.ActorKind + +cdefs :: ContentDef ActorKind +cdefs = ContentDef + { getSymbol = asymbol + , getName = aname + , getFreq = afreq + , validate = validateActorKind + , content = + [hero, projectile, eye, fastEye, nose] + } +hero, projectile, eye, fastEye, nose :: ActorKind + +hero = ActorKind + { asymbol = '@' + , aname = "hero" + , afreq = [("hero", 1)] + , acolor = BrWhite -- modified if many hero factions + , ahp = rollDice 50 1 + , aspeed = toSpeed 2 + , asight = True + , asmell = False + , aiq = 15 -- higher that that leads to looping movement + , aregen = 500 + , acanDo = [minBound..maxBound] + } + +projectile = ActorKind -- includes homing missiles + { asymbol = '*' + , aname = "projectile" + , afreq = [("projectile", 1)] -- Does not appear randomly in the dungeon. + , acolor = BrWhite + , ahp = rollDice 0 0 + , aspeed = toSpeed 0 + , asight = False + , asmell = False + , aiq = 0 + , aregen = maxBound + , acanDo = [Track] + } + +eye = ActorKind + { asymbol = 'e' + , aname = "reducible eye" + , afreq = [("monster", 60), ("horror", 60)] + , acolor = BrRed + , ahp = rollDice 7 4 + , aspeed = toSpeed 2 + , asight = True + , asmell = False + , aiq = 8 + , aregen = 100 + , acanDo = [minBound..maxBound] + } +fastEye = ActorKind + { asymbol = 'e' + , aname = "super-fast eye" + , afreq = [("monster", 15), ("horror", 15)] + , acolor = BrBlue + , ahp = rollDice 1 6 + , aspeed = toSpeed 4 + , asight = True + , asmell = False + , aiq = 12 + , aregen = 10 -- Regenerates fast (at max HP most of the time!). + , acanDo = [minBound..maxBound] + } +nose = ActorKind + { asymbol = 'n' + , aname = "point-free nose" + , afreq = [("monster", 20), ("horror", 20)] + , acolor = Green + , ahp = rollDice 17 2 + , aspeed = toSpeed 1.8 + , asight = False + , asmell = True + , aiq = 0 + , aregen = 100 + , acanDo = [minBound..maxBound] + } diff --git a/GameDefinition/Content/CaveKind.hs b/GameDefinition/Content/CaveKind.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Content/CaveKind.hs @@ -0,0 +1,123 @@ +-- | Cave layouts for LambdaHack. +module Content.CaveKind ( cdefs ) where + +import Data.Ratio + +import Game.LambdaHack.Common.ContentDef +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Random as Random +import Game.LambdaHack.Content.CaveKind + +cdefs :: ContentDef CaveKind +cdefs = ContentDef + { getSymbol = csymbol + , getName = cname + , getFreq = cfreq + , validate = validateCaveKind + , content = + [rogue, arena, empty, noise, combat, battle] + } +rogue, arena, empty, noise, combat, battle :: CaveKind + +rogue = CaveKind + { csymbol = '$' + , cname = "A maze of twisty passages" + , cfreq = [("dng", 100), ("caveRogue", 1)] + , cxsize = fst normalLevelBound + 1 + , cysize = snd normalLevelBound + 1 + , cgrid = rollDiceXY [(3, 2)] [(1, 2), (2, 1)] + , cminPlaceSize = rollDiceXY [(2, 2), (2, 1)] [(4, 1)] + , cmaxPlaceSize = rollDiceXY [(fst normalLevelBound, 1)] + [(snd normalLevelBound, 1)] + , cdarkChance = rollDeep (1, 54) (0, 0) + , cnightChance = intToDeep 100 + , cauxConnects = 1%3 + , cmaxVoid = 1%6 + , cminStairDist = 30 + , cdoorChance = 1%2 + , copenChance = 1%10 + , chidden = 8 + , citemNum = rollDice 7 2 + , citemFreq = [(70, "useful"), (30, "treasure")] + , cdefTile = "fillerWall" + , cdarkCorTile = "floorCorridorDark" + , clitCorTile = "floorCorridorLit" + , cfillerTile = "fillerWall" + , couterFenceTile = "basic outer fence" + , clegendDarkTile = "legendDark" + , clegendLitTile = "legendLit" + } +arena = rogue + { csymbol = 'A' + , cname = "Underground city" + , cfreq = [("dng", 30), ("caveArena", 1)] + , cgrid = rollDiceXY [(2, 2)] [(2, 2)] + , cminPlaceSize = rollDiceXY [(2, 2), (3, 1)] [(4, 1)] + , cdarkChance = rollDeep (1, 80) (1, 60) + , cnightChance = intToDeep 0 + , cmaxVoid = 1%3 + , chidden = 1000 + , citemNum = rollDice 5 2 -- few rooms + , cdefTile = "arenaSet" + , cdarkCorTile = "trailLit" -- let paths around rooms be lit + , clitCorTile = "trailLit" + } +empty = rogue + { csymbol = '.' + , cname = "Tall cavern" + , cfreq = [("dng", 20), ("caveEmpty", 1)] + , cgrid = rollDiceXY [(1, 2), (1, 1)] [(1, 1)] + , cminPlaceSize = rollDiceXY [(10, 1)] [(10, 1)] + , cmaxPlaceSize = rollDiceXY [(fst normalLevelBound * 3 `div` 5, 1)] + [(snd normalLevelBound * 3 `div` 5, 1)] + , cdarkChance = rollDeep (1, 80) (1, 80) + , cnightChance = intToDeep 0 + , cauxConnects = 1 + , cmaxVoid = 1%2 + , cminStairDist = 50 + , chidden = 1000 + , citemNum = rollDice 8 2 -- whole floor strewn with treasure + , cdefTile = "emptySet" + , cdarkCorTile = "trailLit" -- let paths around rooms be lit + , clitCorTile = "floorArenaLit" + } +noise = rogue + { csymbol = '!' + , cname = "Glittering cave" + , cfreq = [("dng", 20), ("caveNoise", 1)] + , cgrid = rollDiceXY [(2, 2)] [(1, 2), (1, 1)] + , cminPlaceSize = rollDiceXY [(3, 2), (2, 1)] [(5, 1)] + , cdarkChance = rollDeep (1, 80) (1, 40) + , cnightChance = rollDeep (1, 40) (1, 40) + , cmaxVoid = 0 + , chidden = 1000 + , citemNum = rollDice 4 2 -- fewer rooms + , cdefTile = "noiseSet" + , cdarkCorTile = "trailLit" -- let trails give off light + , clitCorTile = "trailLit" + } +combat = rogue + { csymbol = 'C' + , cname = "Combat arena" + , cfreq = [("caveCombat", 1)] + , cgrid = rollDiceXY [(2, 2), (3, 1)] [(1, 2), (2, 1)] + , cminPlaceSize = rollDiceXY [(3, 1)] [(3, 1)] + , cmaxPlaceSize = rollDiceXY [(5, 1)] [(5, 1)] + , cdarkChance = intToDeep 100 + , cnightChance = rollDeep (1, 67) (0, 0) + , chidden = 1000 + , cauxConnects = 0 + , cdoorChance = 1 + , copenChance = 0 + , citemNum = rollDice 12 2 + , citemFreq = [(100, "useful")] + , cdefTile = "combatSet" + , cdarkCorTile = "trailLit" -- let trails give off light + , clitCorTile = "floorArenaLit" + } +battle = combat -- TODO: actors can get stuck forever among trees + { csymbol = 'B' + , cname = "Battle arena" + , cfreq = [("caveBattle", 1)] + , cdefTile = "battleSet" + } diff --git a/GameDefinition/Content/FactionKind.hs b/GameDefinition/Content/FactionKind.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Content/FactionKind.hs @@ -0,0 +1,55 @@ +-- | The type of kinds of game factions (heroes, enemies, NPCs, etc.) +-- for LambdaHack. +module Content.FactionKind ( cdefs ) where + +import Game.LambdaHack.Common.Ability +import Game.LambdaHack.Common.ContentDef +import Game.LambdaHack.Content.FactionKind + +cdefs :: ContentDef FactionKind +cdefs = ContentDef + { getSymbol = fsymbol + , getName = fname + , getFreq = ffreq + , validate = validateFactionKind + , content = + [hero, monster, horror] + } +hero, monster, horror :: FactionKind + +hero = FactionKind + { fsymbol = '@' + , fname = "hero" + , ffreq = [("hero", 1)] + , fAbilityLeader = allAbilities + , fAbilityOther = meleeAdjacent + } + +monster = FactionKind + { fsymbol = 'm' + , fname = "monster" + , ffreq = [("monster", 1), ("summon", 50)] + , fAbilityLeader = allAbilities + , fAbilityOther = allAbilities + } + +horror = FactionKind + { fsymbol = 'h' + , fname = "horror" + , ffreq = [("horror", 1), ("summon", 50)] + , fAbilityLeader = allAbilities + , fAbilityOther = allAbilities + } + + +_noAbility, _onlyFollowTrack, meleeAdjacent, _meleeAndRanged, allAbilities :: [Ability] + +_noAbility = [] -- not even projectiles will fly + +_onlyFollowTrack = [Track] -- projectiles enabled + +meleeAdjacent = [Track, Melee] + +_meleeAndRanged = [Track, Melee, Ranged] -- melee and reaction fire + +allAbilities = [minBound..maxBound] diff --git a/GameDefinition/Content/ItemKind.hs b/GameDefinition/Content/ItemKind.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Content/ItemKind.hs @@ -0,0 +1,267 @@ +-- | Weapons and treasure for LambdaHack. +module Content.ItemKind ( cdefs ) where + +import Game.LambdaHack.Common.Color +import Game.LambdaHack.Common.ContentDef +import Game.LambdaHack.Common.Effect +import Game.LambdaHack.Common.Flavour +import Game.LambdaHack.Common.ItemFeature +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Content.ItemKind + +cdefs :: ContentDef ItemKind +cdefs = ContentDef + { getSymbol = isymbol + , getName = iname + , getFreq = ifreq + , validate = validateItemKind + , content = + [amulet, dart, gem1, gem2, gem3, currency, harpoon, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand1, wand2, fist, foot, tentacle, fragrance, mist_healing, mist_wounding, glass_piece, smoke] + } +amulet, dart, gem1, gem2, gem3, currency, harpoon, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand1, wand2, fist, foot, tentacle, fragrance, mist_healing, mist_wounding, glass_piece, smoke :: ItemKind + +gem, potion, scroll, wand :: ItemKind -- generic templates + +-- castDeep (aDb, xDy) = castDice aDb + (lvl - 1) * castDice xDy / (depth - 1) + +amulet = ItemKind + { isymbol = '"' + , iname = "amulet" + , ifreq = [("useful", 6)] + , iflavour = zipFancy [BrGreen] + , icount = intToDeep 1 + , iverbApply = "tear down" + , iverbProject = "cast" + , iweight = 30 + , itoThrow = -50 -- not dense enough + , ifeature = [Cause $ Regeneration (rollDeep (2, 3) (1, 10))] + } +dart = ItemKind + { isymbol = '|' + , iname = "dart" + , ifreq = [("useful", 20)] + , iflavour = zipPlain [Cyan] + , icount = rollDeep (3, 3) (0, 0) + , iverbApply = "snap" + , iverbProject = "hurl" + , iweight = 50 + , itoThrow = 0 -- a cheap dart + , ifeature = [Cause $ Hurt (rollDice 1 2) (rollDeep (1, 2) (1, 2))] + } +gem = ItemKind + { isymbol = '*' + , iname = "gem" + , ifreq = [("treasure", 20)] -- x3, but rare on shallow levels + , iflavour = zipPlain brightCol -- natural, so not fancy + , icount = intToDeep 0 + , iverbApply = "crush" + , iverbProject = "toss" + , iweight = 50 + , itoThrow = 0 + , ifeature = [] + } +gem1 = gem + { icount = rollDeep (0, 0) (1, 1) -- appears on max depth + } +gem2 = gem + { icount = rollDeep (0, 0) (1, 2) -- appears halfway + } +gem3 = gem + { icount = rollDeep (0, 0) (1, 3) -- appears early + } +currency = ItemKind + { isymbol = '$' + , iname = "gold piece" + , ifreq = [("treasure", 20), ("currency", 1)] + , iflavour = zipPlain [BrYellow] + , icount = rollDeep (0, 0) (10, 10) -- appears on lvl 2 + , iverbApply = "grind" + , iverbProject = "toss" + , iweight = 31 + , itoThrow = 0 + , ifeature = [] + } +harpoon = ItemKind + { isymbol = '|' + , iname = "harpoon" + , ifreq = [("useful", 25)] + , iflavour = zipPlain [Brown] + , icount = rollDeep (0, 0) (2, 2) + , iverbApply = "break up" + , iverbProject = "hurl" + , iweight = 4000 + , itoThrow = 0 -- cheap but deadly + , ifeature = [Cause $ Hurt (rollDice 2 2) (rollDeep (1, 2) (2, 2))] + } +potion = ItemKind + { isymbol = '!' + , iname = "potion" + , ifreq = [("useful", 15)] + , iflavour = zipFancy stdCol + , icount = intToDeep 1 + , iverbApply = "gulp down" + , iverbProject = "lob" + , iweight = 200 + , itoThrow = -50 -- oily, bad grip + , ifeature = [] + } +potion1 = potion + { ifreq = [("useful", 5)] + , ifeature = [Cause ApplyPerfume, Explode "fragrance"] + } +potion2 = potion + { ifeature = [Cause $ Heal 5, Explode "mist healing"] + } +potion3 = potion + { ifreq = [("useful", 5)] + , ifeature = [Cause $ Heal (-5), Explode "mist wounding"] + } +ring = ItemKind + { isymbol = '=' + , iname = "ring" + , ifreq = [] -- [("useful", 10)] -- TODO: make it useful + , iflavour = zipPlain [White] + , icount = intToDeep 1 + , iverbApply = "squeeze down" + , iverbProject = "toss" + , iweight = 15 + , itoThrow = 0 + , ifeature = [Cause $ Searching (rollDeep (1, 6) (3, 2))] + } +scroll = ItemKind + { isymbol = '?' + , iname = "scroll" + , ifreq = [("useful", 4)] + , iflavour = zipFancy darkCol -- arcane and old + , icount = intToDeep 1 + , iverbApply = "decipher" + , iverbProject = "lob" + , iweight = 50 + , itoThrow = -75 -- bad shape, even rolled up + , ifeature = [] + } +scroll1 = scroll + { ifreq = [("useful", 2)] + , ifeature = [Cause $ CallFriend 1] + } +scroll2 = scroll + { ifeature = [Cause $ Summon 1] + } +scroll3 = scroll + { ifeature = [Cause $ Ascend (-1)] + } +sword = ItemKind + { isymbol = ')' + , iname = "sword" + , ifreq = [("useful", 40)] + , iflavour = zipPlain [BrCyan] + , icount = intToDeep 1 + , iverbApply = "hit" + , iverbProject = "heave" + , iweight = 2000 + , itoThrow = -50 -- ensuring it hits with the tip costs speed + , ifeature = [Cause $ Hurt (rollDice 5 1) (rollDeep (1, 2) (4, 2))] + } +wand = ItemKind + { isymbol = '/' + , iname = "wand" + , ifreq = [("useful", 5)] + , iflavour = zipFancy brightCol + , icount = intToDeep 1 + , iverbApply = "snap" + , iverbProject = "zap" + , iweight = 300 + , itoThrow = 25 -- magic + , ifeature = [Fragile] + } +wand1 = wand + { ifeature = ifeature wand ++ [Cause Dominate] + } +wand2 = wand + { ifreq = [("useful", 2)] + , ifeature = ifeature wand ++ [Cause $ Heal (-25)] + } +fist = sword + { isymbol = '@' + , iname = "fist" + , ifreq = [("hth", 1), ("unarmed", 100)] + , iverbApply = "punch" + , iverbProject = "ERROR, please report: iverbProject fist" + , ifeature = [Cause $ Hurt (rollDice 5 1) (intToDeep 0)] + } +foot = sword + { isymbol = '@' + , iname = "foot" + , ifreq = [("hth", 1), ("unarmed", 50)] + , iverbApply = "kick" + , iverbProject = "ERROR, please report: iverbProject foot" + , ifeature = [Cause $ Hurt (rollDice 5 1) (intToDeep 0)] + } +tentacle = sword + { isymbol = 'S' + , iname = "tentacle" + , ifreq = [("hth", 1), ("monstrous", 100)] + , iverbApply = "hit" + , iverbProject = "ERROR, please report: iverbProject tentacle" + , ifeature = [Cause $ Hurt (rollDice 5 1) (intToDeep 0)] + } +fragrance = ItemKind + { isymbol = '\'' + , iname = "fragrance" + , ifreq = [("fragrance", 1)] + , iflavour = zipFancy [BrMagenta] + , icount = rollDeep (5, 2) (0, 0) + , iverbApply = "smell" + , iverbProject = "exude" + , iweight = 1 + , itoThrow = -93 -- the slowest that gets anywhere (1 step only) + , ifeature = [Fragile] + } +mist_healing = ItemKind + { isymbol = '\'' + , iname = "mist" + , ifreq = [("mist healing", 1)] + , iflavour = zipFancy [White] + , icount = rollDeep (12, 2) (0, 0) + , iverbApply = "inhale" + , iverbProject = "blow" + , iweight = 1 + , itoThrow = -87 -- the slowest that travels at least 2 steps + , ifeature = [Cause $ Heal 1, Fragile] + } +mist_wounding = ItemKind + { isymbol = '\'' + , iname = "mist" + , ifreq = [("mist wounding", 1)] + , iflavour = zipFancy [White] + , icount = rollDeep (12, 2) (0, 0) + , iverbApply = "inhale" + , iverbProject = "blow" + , iweight = 1 + , itoThrow = -87 + , ifeature = [Cause $ Heal (-1), Fragile] + } +glass_piece = ItemKind + { isymbol = '\'' + , iname = "glass piece" + , ifreq = [("glass piece", 1)] + , iflavour = zipPlain [BrBlue] + , icount = rollDeep (10, 2) (0, 0) + , iverbApply = "grate" + , iverbProject = "toss" + , iweight = 10 + , itoThrow = 0 + , ifeature = [Cause $ Hurt (rollDice 1 1) (intToDeep 0), Fragile, Linger 20] + } +smoke = ItemKind + { isymbol = '\'' + , iname = "smoke" + , ifreq = [("smoke", 1)] + , iflavour = zipPlain [BrBlack] + , icount = rollDeep (12, 2) (0, 0) + , iverbApply = "inhale" + , iverbProject = "blow" + , iweight = 1 + , itoThrow = -70 + , ifeature = [Fragile] + } diff --git a/GameDefinition/Content/ModeKind.hs b/GameDefinition/Content/ModeKind.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Content/ModeKind.hs @@ -0,0 +1,301 @@ +-- | The type of kinds of game modes for LambdaHack. +module Content.ModeKind ( cdefs ) where + +import qualified Data.EnumMap.Strict as EM + +import Game.LambdaHack.Common.ContentDef +import Game.LambdaHack.Content.ModeKind + +cdefs :: ContentDef ModeKind +cdefs = ContentDef + { getSymbol = msymbol + , getName = mname + , getFreq = mfreq + , validate = validateModeKind + , content = + [campaign, skirmish, battle, pvp, coop, defense, testCampaign, testSkirmish, testBattle, testPvP, testCoop, testDefense, peekCampaign, peekSkirmish] + } +campaign, skirmish, battle, pvp, coop, defense, testCampaign, testSkirmish, testBattle, testPvP, testCoop, testDefense, peekCampaign, peekSkirmish :: ModeKind + +campaign = ModeKind + { msymbol = 'r' + , mname = "campaign" + , mfreq = [("campaign", 1)] + , mplayers = playersCampaign + , mcaves = cavesCampaign + } + +skirmish = ModeKind + { msymbol = 'k' + , mname = "skirmish" + , mfreq = [("skirmish", 1)] + , mplayers = playersSkirmish + , mcaves = cavesCombat + } + +battle = ModeKind + { msymbol = 'b' + , mname = "battle" + , mfreq = [("battle", 1)] + , mplayers = playersBattle + , mcaves = cavesBattle + } + +pvp = ModeKind + { msymbol = 'v' + , mname = "PvP" + , mfreq = [("PvP", 1)] + , mplayers = playersPvP + , mcaves = cavesCombat + } + +coop = ModeKind + { msymbol = 'o' + , mname = "Coop" + , mfreq = [("Coop", 1)] + , mplayers = playersCoop + , mcaves = cavesCampaign + } + +defense = ModeKind + { msymbol = 'e' + , mname = "defense" + , mfreq = [("defense", 1)] + , mplayers = playersDefense + , mcaves = cavesCampaign + } + +testCampaign = ModeKind + { msymbol = 't' + , mname = "testCampaign" + , mfreq = [("testCampaign", 1)] + , mplayers = playersTestCampaign + , mcaves = cavesCampaign + } + +testSkirmish = ModeKind + { msymbol = 't' + , mname = "testSkirmish" + , mfreq = [("testSkirmish", 1)] + , mplayers = playersTestSkirmish + , mcaves = cavesCombat + } + +testBattle = ModeKind + { msymbol = 't' + , mname = "testBattle" + , mfreq = [("testBattle", 1)] + , mplayers = playersTestBattle + , mcaves = cavesBattle + } + +testPvP = ModeKind + { msymbol = 't' + , mname = "testPvP" + , mfreq = [("testPvP", 1)] + , mplayers = playersTestPvP + , mcaves = cavesCombat + } + +testCoop = ModeKind + { msymbol = 't' + , mname = "testCoop" + , mfreq = [("testCoop", 1)] + , mplayers = playersTestCoop + , mcaves = cavesCampaign + } + +testDefense = ModeKind + { msymbol = 't' + , mname = "testDefense" + , mfreq = [("testDefense", 1)] + , mplayers = playersTestDefense + , mcaves = cavesCampaign + } + +peekCampaign = ModeKind + { msymbol = 'p' + , mname = "peekCampaign" + , mfreq = [("peekCampaign", 1)] + , mplayers = playersPeekCampaign + , mcaves = cavesCampaign + } + +peekSkirmish = ModeKind + { msymbol = 'p' + , mname = "peekSkirmish" + , mfreq = [("peekSkirmish", 1)] + , mplayers = playersPeekSkirmish + , mcaves = cavesCombat + } + + +playersCampaign, playersSkirmish, playersBattle, playersPvP, playersCoop, playersDefense, playersTestCampaign, playersTestSkirmish, playersTestBattle, playersTestPvP, playersTestCoop, playersTestDefense, playersPeekCampaign, playersPeekSkirmish :: Players + +playersCampaign = Players + { playersList = [ playerHero {playerInitial = 1} + , playerMonster ] + , playersEnemy = [("Adventurer Party", "Monster Hive")] + , playersAlly = [] } + +playersSkirmish = Players + { playersList = [ playerHero {playerName = "White"} + , playerAntiHero {playerName = "Purple"} + , playerHorror ] + , playersEnemy = [ ("White", "Purple") + , ("White", "Horror Den") + , ("Purple", "Horror Den") ] + , playersAlly = [] } + +playersBattle = Players + { playersList = [ playerHero {playerInitial = 5} + , playerMonster { playerInitial = 30 + , playerSpawn = 0 } ] + , playersEnemy = [("Adventurer Party", "Monster Hive")] + , playersAlly = [] } + +playersPvP = Players + { playersList = [ playerHero {playerName = "Red"} + , playerHero {playerName = "Blue"} + , playerHorror ] + , playersEnemy = [ ("Red", "Blue") + , ("Red", "Horror Den") + , ("Blue", "Horror Den") ] + , playersAlly = [] } + +playersCoop = Players + { playersList = [ playerHero { playerName = "Coral" + , playerInitial = 1 } + , playerHero { playerName = "Amber" + , playerInitial = 1 } + , playerMonster ] + , playersEnemy = [ ("Coral", "Monster Hive") + , ("Amber", "Monster Hive") ] + , playersAlly = [("Coral", "Amber")] } + +playersDefense = Players + { playersList = [ playerMonster { playerInitial = 1 + , playerAiLeader = False + , playerHuman = True + , playerUI = True } + , playerAntiHero {playerName = "Green"} + , playerAntiHero {playerName = "Yellow"} + , playerAntiHero {playerName = "Cyan"} ] + , playersEnemy = [ ("Green", "Monster Hive") + , ("Yellow", "Monster Hive") + , ("Cyan", "Monster Hive") ] + , playersAlly = [ ("Green", "Yellow") + , ("Green", "Cyan") + , ("Yellow", "Cyan") ] } + +playersTestCampaign = playersCampaign + { playersList = [ playerHero { playerInitial = 5 + , playerAiLeader = True + , playerHuman = False } + , playerMonster ] } + +playersTestSkirmish = playersSkirmish + { playersList = [ playerHero { playerName = "White" + , playerAiLeader = True + , playerHuman = False } + , playerAntiHero { playerName = "Purple" } + , playerHorror ] } + +playersTestBattle = playersBattle + { playersList = [ playerHero { playerInitial = 5 + , playerAiLeader = True + , playerHuman = False } + , playerMonster { playerInitial = 30 + , playerSpawn = 0 } ] } + +playersTestPvP = playersPvP + { playersList = [ playerHero { playerName = "Red" + , playerAiLeader = True + , playerHuman = False } + , playerHero { playerName = "Blue" + , playerAiLeader = True + , playerHuman = False } + , playerHorror ] } + +playersTestCoop = playersCoop + { playersList = [ playerHero { playerName = "Coral" + , playerAiLeader = True + , playerHuman = False } + , playerHero { playerName = "Amber" + , playerAiLeader = True + , playerHuman = False } + , playerMonster ] } + +playersTestDefense = playersDefense + { playersList = [ playerMonster { playerInitial = 1 + , playerUI = True } + , playerAntiHero {playerName = "Green"} + , playerAntiHero {playerName = "Yellow"} + , playerAntiHero {playerName = "Cyan"} ] } + +playersPeekCampaign = playersCampaign + { playersList = [ playerHero {playerInitial = 1} + , playerMonster {playerUI = True} ] } + +playersPeekSkirmish = playersSkirmish + { playersList = [ playerHero {playerName = "White"} + , playerAntiHero { playerName = "Purple" + , playerUI = True } + , playerHorror ] } + + +playerHero, playerAntiHero, playerMonster, playerHorror :: Player + +playerHero = Player + { playerName = "Adventurer Party" + , playerFaction = "hero" + , playerSpawn = 0 + , playerEntry = toEnum (-1) + , playerInitial = 3 + , playerAiLeader = False + , playerAiOther = True + , playerHuman = True + , playerUI = True + } + +playerAntiHero = playerHero + { playerAiLeader = True + , playerHuman = False + , playerUI = False + } + +playerMonster = Player + { playerName = "Monster Hive" + , playerFaction = "monster" + , playerSpawn = 50 + , playerEntry = toEnum (-3) + , playerInitial = 5 + , playerAiLeader = True + , playerAiOther = True + , playerHuman = False + , playerUI = False + } + +playerHorror = Player + { playerName = "Horror Den" + , playerFaction = "horror" + , playerSpawn = 0 + , playerEntry = toEnum (-1) + , playerInitial = 0 + , playerAiLeader = True + , playerAiOther = True + , playerHuman = False + , playerUI = False + } + + +cavesCampaign, cavesCombat, cavesBattle :: Caves + +cavesCampaign = EM.fromList [ (toEnum (-1), ("caveRogue", Just True)) + , (toEnum (-2), ("caveRogue", Nothing)) + , (toEnum (-3), ("caveEmpty", Nothing)) + , (toEnum (-10), ("caveNoise", Nothing))] + +cavesCombat = EM.fromList [(toEnum (-3), ("caveCombat", Nothing))] + +cavesBattle = EM.fromList [(toEnum (-3), ("caveBattle", Nothing))] diff --git a/GameDefinition/Content/PlaceKind.hs b/GameDefinition/Content/PlaceKind.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Content/PlaceKind.hs @@ -0,0 +1,71 @@ +-- | Rooms, halls and passages for LambdaHack. +module Content.PlaceKind ( cdefs ) where + +import Game.LambdaHack.Common.ContentDef +import Game.LambdaHack.Content.PlaceKind + +cdefs :: ContentDef PlaceKind +cdefs = ContentDef + { getSymbol = psymbol + , getName = pname + , getFreq = pfreq + , validate = validatePlaceKind + , content = + [rect, pillar, pillarC, pillar3, colonnade, colonnadeW] + } +rect, pillar, pillarC, pillar3, colonnade, colonnadeW :: PlaceKind + +rect = PlaceKind -- Valid for any nonempty area, hence low frequency. + { psymbol = 'r' + , pname = "room" + , pfreq = [("rogue", 100)] + , pcover = CStretch + , pfence = FNone + , ptopLeft = [ "--" + , "|." + ] + } +pillar = PlaceKind + { psymbol = 'p' + , pname = "pillar room" + , pfreq = [("rogue", 1000)] -- larger rooms require support pillars + , pcover = CStretch + , pfence = FNone + , ptopLeft = [ "-----" + , "|...." + , "|.O.." + , "|...." + , "|...." + ] + } +pillarC = pillar + { ptopLeft = [ "-----" + , "|O..." + , "|...." + , "|...." + , "|...." + ] + } +pillar3 = pillar + { ptopLeft = [ "-----" + , "|&.O." + , "|...." + , "|O..." + , "|...." + ] + } +colonnade = PlaceKind + { psymbol = 'c' + , pname = "colonnade" + , pfreq = [("rogue", 500)] + , pcover = CAlternate + , pfence = FFloor + , ptopLeft = [ "O." + , ".O" + ] + } +colonnadeW = colonnade + { ptopLeft = [ "O." + , ".." + ] + } diff --git a/GameDefinition/Content/RuleKind.hs b/GameDefinition/Content/RuleKind.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Content/RuleKind.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | Game rules and assorted game setup data for LambdaHack. +module Content.RuleKind ( cdefs ) where + +import Control.Arrow (first) +import Language.Haskell.TH.Syntax +import System.FilePath + +-- Cabal +import qualified Paths_LambdaHack as Self (getDataFileName, version) + +import Game.LambdaHack.Common.ContentDef +import qualified Game.LambdaHack.Common.Effect as Effect +import qualified Game.LambdaHack.Common.Feature as F +import Game.LambdaHack.Common.HumanCmd +import qualified Game.LambdaHack.Common.Key as K +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.RuleKind + +cdefs :: ContentDef RuleKind +cdefs = ContentDef + { getSymbol = rsymbol + , getName = rname + , getFreq = rfreq + , validate = validateRuleKind + , content = + [standard] + } + +standard :: RuleKind +standard = RuleKind + { rsymbol = 's' + , rname = "standard LambdaHack ruleset" + , rfreq = [("standard", 100)] + -- Check whether one position is accessible from another. + -- Precondition: the two positions are next to each other. + -- Apart of checking the target tile, we forbid diagonal movement + -- to and from doors. + , raccessible = Nothing + , raccessibleDoor = Just $ \spos tpos -> + not $ isDiagonal $ displacement spos tpos + , rtitle = "LambdaHack" + , rpathsDataFile = Self.getDataFileName + , rpathsVersion = Self.version + , ritemMelee = ")" + , ritemRanged = "|" + -- Wasting weapons and armour would be too cruel to the player. + , ritemProject = "!?|/" + -- The strings containing the default configuration file + -- included from config.ui.default. + , rcfgUIName = "config.ui" + , rcfgUIDefault = $(do + let path = "GameDefinition" "config.ui" <.> "default" + qAddDependentFile path + x <- qRunIO (readFile path) + lift x) + -- ASCII art for the Main Menu. Only pure 7-bit ASCII characters are + -- allowed. The picture should be exactly 24 rows by 80 columns, + -- plus an extra frame (of any characters) that is ignored. + -- For a different screen size, the picture is centered and the outermost + -- rows and columns cloned. When displayed in the Main Menu screen, + -- it's overwritten with the game version string and keybinding strings. + -- The game version string begins and ends with a space and is placed + -- in the very bottom right corner. The keybindings overwrite places + -- marked with 25 left curly brace signs '{' in a row. The sign is forbidden + -- everywhere else. A specific number of such places with 25 left braces + -- are required, at most one per row, and all are overwritten + -- with text that is flushed left and padded with spaces. + -- The Main Menu is displayed dull white on black. + -- TODO: Show highlighted keybinding in inverse video or bright white on grey + -- background. The spaces that pad keybindings are not highlighted. + , rmainMenuArt = $(do + let path = "GameDefinition/MainMenu.ascii" + qAddDependentFile path + x <- qRunIO (readFile path) + lift x) + , rhumanCommands = map (first K.mkKM) + -- All commands are defined here, except some movement and leader picking + -- commands. All commands are shown on help screens except debug commands + -- and macros with empty descriptions. + -- The order below determines the order on the help screens. + -- Remember to put commands that show information (e.g., enter targeting + -- mode) first. + + -- Main Menu, which apart of these includes a few extra commands + [ ("CTRL-x", (CmdMenu, GameExit)) + , ("CTRL-r", (CmdMenu, GameRestart "campaign")) + , ("CTRL-k", (CmdMenu, GameRestart "skirmish")) + , ("CTRL-v", (CmdMenu, GameRestart "PvP")) + , ("CTRL-o", (CmdMenu, GameRestart "Coop")) + , ("CTRL-e", (CmdMenu, GameRestart "defense")) + , ("CTRL-d", (CmdMenu, GameDifficultyCycle)) + + -- Movement and terrain alteration + , ("less", (CmdMove, TriggerTile + [ TriggerFeature { verb = "ascend" + , object = "a level" + , feature = F.Cause (Effect.Ascend 1) } + , TriggerFeature { verb = "escape" + , object = "dungeon" + , feature = F.Cause (Effect.Escape 1) } ])) + , ("CTRL-less", (CmdMove, TriggerTile + [ TriggerFeature { verb = "ascend" + , object = "10 levels" + , feature = F.Cause (Effect.Ascend 10) } ])) + , ("greater", (CmdMove, TriggerTile + [ TriggerFeature { verb = "descend" + , object = "a level" + , feature = F.Cause (Effect.Ascend (-1)) } + , TriggerFeature { verb = "escape" + , object = "dungeon" + , feature = F.Cause (Effect.Escape (-1)) } ])) + , ("CTRL-greater", (CmdMove, TriggerTile + [ TriggerFeature { verb = "descend" + , object = "10 levels" + , feature = F.Cause (Effect.Ascend (-10)) } ])) + , ("CTRL-semicolon", (CmdMove, StepToTarget)) + , ("semicolon", (CmdMove, Macro "go to target for 100 steps" + ["CTRL-semicolon", "P"])) + , ("x", (CmdMove, Macro "explore the closest unknown spot" + [ "BackSpace" + , "CTRL-question", "CTRL-semicolon", "P" ])) + , ("X", (CmdMove, Macro "autoexplore 100 times" + [ "BackSpace" + , "'", "CTRL-question", "CTRL-semicolon", "'" + , "P" ])) + , ("R", (CmdMove, Macro "rest (wait 100 times)" ["KP_Begin", "P"])) + , ("c", (CmdMove, AlterDir + [ AlterFeature { verb = "close" + , object = "door" + , feature = F.CloseTo "vertical closed door Lit" } + , AlterFeature { verb = "close" + , object = "door" + , feature = F.CloseTo "horizontal closed door Lit" } + , AlterFeature { verb = "close" + , object = "door" + , feature = F.CloseTo "vertical closed door Dark" } + , AlterFeature { verb = "close" + , object = "door" + , feature = F.CloseTo "horizontal closed door Dark" } + ])) + , ("o", (CmdMove, AlterDir + [ AlterFeature { verb = "open" + , object = "door" + , feature = F.OpenTo "vertical open door Lit" } + , AlterFeature { verb = "open" + , object = "door" + , feature = F.OpenTo "horizontal open door Lit" } + , AlterFeature { verb = "open" + , object = "door" + , feature = F.OpenTo "vertical open door Dark" } + , AlterFeature { verb = "open" + , object = "door" + , feature = F.OpenTo "horizontal open door Dark" } + ])) + + -- Inventory and items + , ("I", (CmdItem, Inventory)) + , ("g", (CmdItem, Pickup)) + , ("d", (CmdItem, Drop)) + , ("q", (CmdItem, Apply [ApplyItem { verb = "quaff" + , object = "potion" + , symbol = '!' }])) + , ("r", (CmdItem, Apply [ApplyItem { verb = "read" + , object = "scroll" + , symbol = '?' }])) + , ("t", (CmdItem, Project [ApplyItem { verb = "throw" + , object = "missile" + , symbol = '|' }])) + , ("z", (CmdItem, Project [ApplyItem { verb = "zap" + , object = "wand" + , symbol = '/' }])) + + -- Targeting + , ("asterisk", (CmdTgt, TgtEnemy)) + , ("slash", (CmdTgt, TgtFloor)) + , ("plus", (CmdTgt, EpsIncr True)) + , ("minus", (CmdTgt, EpsIncr False)) + , ("BackSpace", (CmdTgt, TgtClear)) + , ("CTRL-question", (CmdTgt, TgtUnknown)) + , ("CTRL-I", (CmdTgt, TgtItem)) + , ("CTRL-braceleft", (CmdTgt, TgtStair True)) + , ("CTRL-braceright", (CmdTgt, TgtStair False)) + + -- Assorted + , ("question", (CmdMeta, Help)) + , ("D", (CmdMeta, History)) + , ("T", (CmdMeta, MarkSuspect)) + , ("V", (CmdMeta, MarkVision)) + , ("S", (CmdMeta, MarkSmell)) + , ("Tab", (CmdMeta, MemberCycle)) + , ("ISO_Left_Tab", (CmdMeta, MemberBack)) + , ("equal", (CmdMeta, SelectActor)) + , ("underscore", (CmdMeta, SelectNone)) + , ("p", (CmdMeta, Repeat 1)) + , ("P", (CmdMeta, Repeat 100)) + , ("CTRL-p", (CmdMeta, Repeat 1000)) + , ("apostrophe", (CmdMeta, Record)) + , ("space", (CmdMeta, Clear)) + , ("Escape", (CmdMeta, Cancel)) + , ("Return", (CmdMeta, Accept)) + + -- Debug and others not to display in help screens + , ("CTRL-s", (CmdDebug, GameSave)) + , ("CTRL-y", (CmdDebug, Resend)) + ] + , rfirstDeathEnds = False + , rfovMode = Digital 12 + , rsaveBkpClips = 500 + , rleadLevelClips = 100 + , rscoresFile = "scores" + , rsavePrefix = "save" + } diff --git a/GameDefinition/Content/TileKind.hs b/GameDefinition/Content/TileKind.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Content/TileKind.hs @@ -0,0 +1,260 @@ +-- | Terrain tiles for LambdaHack. +module Content.TileKind ( cdefs ) where + +import Control.Arrow (first) +import Data.Text (Text) +import qualified Data.Text as T + +import Game.LambdaHack.Common.Color +import Game.LambdaHack.Common.ContentDef +import qualified Game.LambdaHack.Common.Effect as Effect +import Game.LambdaHack.Common.Feature +import Game.LambdaHack.Common.Msg +import Game.LambdaHack.Content.TileKind + +cdefs :: ContentDef TileKind +cdefs = ContentDef + { getSymbol = tsymbol + , getName = tname + , getFreq = tfreq + , validate = validateTileKind + , content = + [wall, hardRock, pillar, pillarCache, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpLit, stairsLit, stairsDownLit, escapeUpLit, escapeDownLit, unknown, floorCorridorLit, floorArenaLit, floorActorLit, floorItemLit, floorActorItemLit, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit] + ++ map makeDark [wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsLit, escapeUpLit, escapeDownLit, floorCorridorLit] + ++ map makeDarkColor [stairsUpLit, stairsDownLit, floorArenaLit, floorActorLit, floorItemLit, floorActorItemLit] + } +wall, hardRock, pillar, pillarCache, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpLit, stairsLit, stairsDownLit, escapeUpLit, escapeDownLit, unknown, floorCorridorLit, floorArenaLit, floorActorLit, floorItemLit, floorActorItemLit, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit :: TileKind + +wall = TileKind + { tsymbol = ' ' + , tname = "bedrock" + , tfreq = [("fillerWall", 1), ("legendLit", 100), ("legendDark", 100)] + , tcolor = defBG + , tcolor2 = defBG + , tfeature = [Dark] + } +hardRock = TileKind + { tsymbol = ' ' + , tname = "impenetrable bedrock" + , tfreq = [("basic outer fence", 1)] + , tcolor = BrWhite + , tcolor2 = BrWhite + , tfeature = [Dark, Impenetrable] + } +pillar = TileKind + { tsymbol = 'O' + , tname = "rock" + , tfreq = [ ("cachable", 70) + , ("legendLit", 100), ("legendDark", 100) + , ("noiseSet", 55), ("combatSet", 3), ("battleSet", 9) ] + , tcolor = BrWhite + , tcolor2 = defFG + , tfeature = [] + } +pillarCache = TileKind + { tsymbol = '&' + , tname = "cache" + , tfreq = [ ("cachable", 30) + , ("legendLit", 100), ("legendDark", 100) ] + , tcolor = BrWhite + , tcolor2 = defFG + , tfeature = [Suspect, Cause $ Effect.CreateItem 1, ChangeTo "cachable"] + } +tree = TileKind + { tsymbol = 'O' + , tname = "tree" + , tfreq = [("combatSet", 8)] + , tcolor = BrGreen + , tcolor2 = Green + , tfeature = [] + } +wallV = TileKind + { tsymbol = '|' + , tname = "granite wall" + , tfreq = [("legendLit", 100)] + , tcolor = BrWhite + , tcolor2 = defFG + , tfeature = [HideAs "suspect vertical wall Lit"] + } +wallSuspectV = TileKind + { tsymbol = '|' + , tname = "moldy wall" + , tfreq = [("suspect vertical wall Lit", 1)] + , tcolor = BrWhite + , tcolor2 = defFG + , tfeature = [Suspect, RevealAs "vertical closed door Lit"] + } +doorClosedV = TileKind + { tsymbol = '+' + , tname = "closed door" + , tfreq = [("vertical closed door Lit", 1)] + , tcolor = Brown + , tcolor2 = BrBlack + , tfeature = [ OpenTo "vertical open door Lit" + , HideAs "suspect vertical wall Lit" + ] + } +doorOpenV = TileKind + { tsymbol = '-' + , tname = "open door" + , tfreq = [("vertical open door Lit", 1)] + , tcolor = Brown + , tcolor2 = BrBlack + , tfeature = [ Walkable, Clear + , CloseTo "vertical closed door Lit" + ] + } +wallH = TileKind + { tsymbol = '-' + , tname = "granite wall" + , tfreq = [("legendLit", 100)] + , tcolor = BrWhite + , tcolor2 = defFG + , tfeature = [HideAs "suspect horizontal wall Lit"] + } +wallSuspectH = TileKind + { tsymbol = '-' + , tname = "scratched wall" + , tfreq = [("suspect horizontal wall Lit", 1)] + , tcolor = BrWhite + , tcolor2 = defFG + , tfeature = [Suspect, RevealAs "horizontal closed door Lit"] + } +doorClosedH = TileKind + { tsymbol = '+' + , tname = "closed door" + , tfreq = [("horizontal closed door Lit", 1)] + , tcolor = Brown + , tcolor2 = BrBlack + , tfeature = [ OpenTo "horizontal open door Lit" + , HideAs "suspect horizontal wall Lit" + ] + } +doorOpenH = TileKind + { tsymbol = '|' + , tname = "open door" + , tfreq = [("horizontal open door Lit", 1)] + , tcolor = Brown + , tcolor2 = BrBlack + , tfeature = [ Walkable, Clear + , CloseTo "horizontal closed door Lit" + ] + } +stairsUpLit = TileKind + { tsymbol = '<' + , tname = "staircase up" + , tfreq = [("legendLit", 100)] + , tcolor = BrWhite + , tcolor2 = defFG + , tfeature = [Walkable, Clear, Cause $ Effect.Ascend 1] + } +stairsLit = TileKind + { tsymbol = '>' + , tname = "staircase" + , tfreq = [("legendLit", 100)] + , tcolor = BrCyan + , tcolor2 = Cyan -- TODO + , tfeature = [ Walkable, Clear + , Cause $ Effect.Ascend 1 + , Cause $ Effect.Ascend (-1) ] + } +stairsDownLit = TileKind + { tsymbol = '>' + , tname = "staircase down" + , tfreq = [("legendLit", 100)] + , tcolor = BrWhite + , tcolor2 = defFG + , tfeature = [Walkable, Clear, Cause $ Effect.Ascend (-1)] + } +escapeUpLit = TileKind + { tsymbol = '<' + , tname = "exit trapdoor up" + , tfreq = [("legendLit", 100)] + , tcolor = BrYellow + , tcolor2 = BrYellow + , tfeature = [Walkable, Clear, Cause (Effect.Escape 1)] + } +escapeDownLit = TileKind + { tsymbol = '>' + , tname = "exit trapdoor down" + , tfreq = [("legendLit", 100)] + , tcolor = BrYellow + , tcolor2 = BrYellow + , tfeature = [Walkable, Clear, Cause (Effect.Escape (-1))] + } +unknown = TileKind + { tsymbol = ' ' + , tname = "unknown space" + , tfreq = [("unknown space", 1)] + , tcolor = defFG + , tcolor2 = defFG + , tfeature = [Dark] + } +floorCorridorLit = TileKind + { tsymbol = '#' + , tname = "corridor" + , tfreq = [("floorCorridorLit", 1)] + , tcolor = BrWhite + , tcolor2 = defFG + , tfeature = [Walkable, Clear] + } +floorArenaLit = floorCorridorLit + { tsymbol = '.' + , tname = "stone floor" + , tfreq = [ ("floorArenaLit", 1) + , ("arenaSet", 1), ("noiseSet", 100), ("combatSet", 100) ] + } +floorActorLit = floorArenaLit + { tfreq = [("floorActorLit", 1), ("battleSet", 100)] + , tfeature = CanActor : tfeature floorArenaLit + } +floorItemLit = floorArenaLit + { tfreq = [] + , tfeature = CanItem : tfeature floorArenaLit + } +floorActorItemLit = floorItemLit + { tfreq = [("legendLit", 100), ("emptySet", 1)] + , tfeature = CanActor : tfeature floorItemLit + } +floorRedLit = floorArenaLit + { tname = "brick pavement" + , tfreq = [("trailLit", 30)] + , tcolor = BrRed + , tcolor2 = Red + , tfeature = Trail : tfeature floorArenaLit + } +floorBlueLit = floorRedLit + { tname = "granite cobblestones" + , tfreq = [("trailLit", 100)] + , tcolor = BrBlue + , tcolor2 = Blue + } +floorGreenLit = floorRedLit + { tname = "mossy stone path" + , tfreq = [("trailLit", 100)] + , tcolor = BrGreen + , tcolor2 = Green + } +floorBrownLit = floorRedLit + { tname = "rotting mahogany deck" + , tfreq = [("trailLit", 10)] + , tcolor = BrMagenta + , tcolor2 = Magenta + } + +makeDark :: TileKind -> TileKind +makeDark k = let textLit :: Text -> Text + textLit t = maybe t (<> "Dark") $ T.stripSuffix "Lit" t + litFreq = map (first textLit) $ tfreq k + litFeat (OpenTo t) = OpenTo $ textLit t + litFeat (CloseTo t) = CloseTo $ textLit t + litFeat (ChangeTo t) = ChangeTo $ textLit t + litFeat (HideAs t) = HideAs $ textLit t + litFeat (RevealAs t) = RevealAs $ textLit t + litFeat feat = feat + in k { tfreq = litFreq + , tfeature = Dark : map litFeat (tfeature k) + } + +makeDarkColor :: TileKind -> TileKind +makeDarkColor k = (makeDark k) {tcolor2 = BrBlack} diff --git a/GameDefinition/Main.hs b/GameDefinition/Main.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Main.hs @@ -0,0 +1,50 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | The main source code file of LambdaHack. Here the knot of engine +-- code pieces and the LambdaHack-specific content defintions is tied, +-- resulting in an executable game. +module Main ( main ) where + +import qualified Content.ActorKind +import qualified Content.CaveKind +import qualified Content.FactionKind +import qualified Content.ItemKind +import qualified Content.ModeKind +import qualified Content.PlaceKind +import qualified Content.RuleKind +import qualified Content.TileKind +import Game.LambdaHack.Client +import Game.LambdaHack.Client.Action.ActionType +import Game.LambdaHack.Common.Action (MonadAtomic (..)) +import Game.LambdaHack.Common.AtomicCmd +import Game.LambdaHack.Common.AtomicSem +import qualified Game.LambdaHack.Common.Kind as Kind +import Game.LambdaHack.Server +import Game.LambdaHack.Server.Action.ActionType +import Game.LambdaHack.Server.AtomicSemSer + +-- | The game-state semantics of atomic game commands +-- as computed on the server. +instance MonadAtomic ActionSer where + execAtomic = atomicSendSem + +-- | The game-state semantics of atomic game commands +-- as computed on clients. Special effects (@SfxAtomic@) don't modify state. +instance MonadAtomic (ActionCli c d) where + execAtomic (CmdAtomic cmd) = cmdAtomicSem cmd + execAtomic (SfxAtomic _) = return () + +-- | Tie the LambdaHack engine clients and server code +-- with the LambdaHack-specific content defintions and run the game. +main :: IO () +main = + let copsSlow = Kind.COps + { coactor = Kind.createOps Content.ActorKind.cdefs + , cocave = Kind.createOps Content.CaveKind.cdefs + , cofaction = Kind.createOps Content.FactionKind.cdefs + , coitem = Kind.createOps Content.ItemKind.cdefs + , comode = Kind.createOps Content.ModeKind.cdefs + , coplace = Kind.createOps Content.PlaceKind.cdefs + , corule = Kind.createOps Content.RuleKind.cdefs + , cotile = Kind.createOps Content.TileKind.cdefs + } + in mainSer copsSlow executorSer $ exeFrontend executorCli executorCli diff --git a/GameDefinition/MainMenu.ascii b/GameDefinition/MainMenu.ascii new file mode 100644 --- /dev/null +++ b/GameDefinition/MainMenu.ascii @@ -0,0 +1,26 @@ +---------------------------------------------------------------------------------- +| | +| >> LambdaHack << | +| | +| | +| {{{{{{{{{{{{{{{{{{{{{{{{{ | +| | +| {{{{{{{{{{{{{{{{{{{{{{{{{ | +| | +| {{{{{{{{{{{{{{{{{{{{{{{{{ | +| | +| {{{{{{{{{{{{{{{{{{{{{{{{{ | +| | +| {{{{{{{{{{{{{{{{{{{{{{{{{ | +| | +| {{{{{{{{{{{{{{{{{{{{{{{{{ | +| | +| {{{{{{{{{{{{{{{{{{{{{{{{{ | +| | +| {{{{{{{{{{{{{{{{{{{{{{{{{ | +| | +| {{{{{{{{{{{{{{{{{{{{{{{{{ | +| | +| | +| Version X.X.X (frontend: gtk, engine: LambdaHack X.X.X) | +---------------------------------------------------------------------------------- diff --git a/GameDefinition/PLAYING.md b/GameDefinition/PLAYING.md new file mode 100644 --- /dev/null +++ b/GameDefinition/PLAYING.md @@ -0,0 +1,204 @@ +Playing LambdaHack +================== + +LambdaHack is a small dungeon crawler illustrating the roguelike game engine +library also called LambdaHack. Playing the game involves walking around +the dungeon, alone or in a party of fearless adventurers, setting up ambushes, +hiding in shadow, covering tracks, breaking through to deeper caves, +bumping into monsters, doors and walls, gathering magical treasure +and making creative use of it. The bloodthirsty monsters do the same, +intelligence allowing, while tirelessly chasing the elusive heroes +by smell and sight. + +Once the few basic command keys and on-screen symbols are learned, +mastery and enjoyment of the game is the matter of tactical skill +and literary imagination. To be honest, a lot of imagination is required +for this rudimentary game, but it's playable and winnable. +The game also features experimental multiplayer cooperative and competitive +modes, but they are troublesome to play with the shared-screen +and shared-keyboard interface available at this time. +Contributions welcome. + + +Dungeon +------- + +The heroes are marked on the map with symbols `@` and `1` through `9`. +Their goal is to explore the dungeon, battle the horrors within, +gather as much gold and gems as possible, and escape to tell the tale. +The dungeon of the campaign mode game consists of 10 levels and each level +consists of a large number of tiles. The basic tile kinds are as follows. + + dungeon terrain type on-screen symbol + floor . + corridor # + wall (horizontal and vertical) - and | + rock or tree O + cache & + stairs up < + stairs down > + open door | and - + closed door + + bedrock blank + +The game world is persistent, i.e., every time the player visits a level +during a single game, the level layout is the same. + + +Keys +---- + +You move throughout the level using the numerical keypad or +the vi text editor keys (also known as "Rogue-like keys"). + + 7 8 9 y k u + \|/ \|/ + 4-5-6 h-.-l + /|\ /|\ + 1 2 3 b j n + +`SHIFT` (or `CTRL`) and a movement key make the current party leader +(and currently selected party members, if any) run in the indicated +direction, until anything of interest is spotted. +The `5` and `.` keys consume a turn and make you brace for combat, +which confers a chance to block blows for the remainder of the turn. +In targeting mode the same keys move the targeting cursor. + +Melee, searching for secret doors and opening closed doors +can be done by bumping into a monster, a wall and a door, respectively. +Few commands other than movement are necessary for casual play. +Some are provided only as building blocks for more complex convenience +commands, e.g., the autoexplore command (key `X`) could be defined +by the player as a macro using `BACKSPACE`, `CTRL-?`, `CTRL-;` and `P`. + +Below are the remaining keys for movement and terrain alteration. + + keys command + < ascend a level + CTRL-< ascend 10 levels + > descend a level + CTRL-> descend 10 levels + CTRL-; make one step towards the target + ; go to target for 100 steps + x explore the closest unknown spot + X autoexplore 100 times + R rest (wait 100 times) + c close door + o open door + +Inventory and items-related keys are as follows. + + keys command + I display inventory + g and , get an object + d drop an object + q quaff potion + r read scroll + t throw missile + z zap wand + +To make a ranged attack, as in the last few commands above, +you need to set your target first (however, initial target is set +automatically as soon as a monster comes into view). Once in targeting mode, +you can move the targeting cursor with arrow keys and switch focus +among enemies with `*` (or among friends and enemies, depending +on targeting mode set by `/`). The details of the shared cursor position +and of the personal target are described at the bottom of the screen. +All targeting keys are listed below. + + keys command + * target enemy + / cycle targeting mode + + swerve targeting line + - unswerve targeting line + BACKSPACE clear target/cursor + CTRL-? target the closest unknown spot + CTRL-I target the closest item + CTRL-{ target the closest stairs up + CTRL-} target the closest stairs down + +Assorted remaining keys and commands follow. + + keys command + ? display help + D display player diary + T mark suspect terrain + V mark visible area + S mark smell + TAB cycle among party members on the level + SHIFT-TAB cycle among party members in the dungeon + = select (or deselect) a party member + _ deselect (or select) all on the level + p play back last keys + P play back last keys 100 times + CTRL-p play back last keys 1000 times + ' start recording a macro + SPACE clear messages + ESC cancel action + RET accept choice + 0--9 pick a new hero leader anywhere in the dungeon + +Commands for saving and exiting the current game, starting a new game, etc., +are listed in the Main Menu, brought up by the `ESC` key. +All but the campaign and skirmish game modes are experimental +and feature multiple human or computer players (allied or not). +Game difficulty setting affects hitpoints at birth for any actors +of any UI-using faction. + + keys command + CTRL-x save and exit + CTRL-r new campaign game + CTRL-k new skirmish game + CTRL-v new PvP game + CTRL-o new Coop game + CTRL-e new defense game + CTRL-d cycle next game difficulty + +There are also some debug, testing and cheat options and game modes +that can be specified on the command line when starting the game server. +Use at your own peril! :) Of these, you may find the screensaver modes +the least spoilery and the most fun, e.g.: + + LambdaHack --newGame --noMore --maxFps 45 --savePrefix test --gameMode testCampaign --difficulty 1 + + +Monsters +-------- + +Heroes are not alone in the dungeon. Monsters roam the dark caves +and crawl from damp holes day and night. While heroes pay attention +to all other party members and take care to move one at a time, +monsters don't care about each other and all move at once, +sometimes brutally colliding by accident. + +When the hero bumps into a monster or a monster attacks the hero, +melee combat occurs. The best weapon carried by each opponent +is taken into account for calculating bonus damage. The total damage +the current hero can potentially inflict is displayed at the bottom +of the screen. The total damage potential of a monster may change +as it finds and picks up new weapons. Heroes and monsters running into +one another (with the `SHIFT` key) do not inflict damage, but change places. +This gives the opponent a free blow, but can improve the tactical situation +or aid escape. + +Throwing weapons at targets wounds them, consuming the weapon in the process. +You may throw any object in your possession (press `?` to choose +an object and press it again for a non-standard choice) or on the floor +(press `-`). Only objects of a few kinds inflict any damage. +Whenever the monster's or hero's hit points reach zero, the combatant dies. +When the last hero dies, the game ends. + + +On Winning and Dying +-------------------- + +You win the game if you escape the dungeon alive (or eliminate +all opposition, in some game modes). Your score is +the sum of all gold you've plundered plus 100 gold pieces for each gem. +Only the loot in possession of the party members on the current level +counts (the rest of the party is considered MIA). + +If all heroes die, your score is halved and only the treasure carried +by the last standing hero counts. You are free to start again +from a different entrance to the dungeon, but all your previous wealth +is gone and fresh, undaunted enemies bar your way. diff --git a/GameDefinition/config.ui.default b/GameDefinition/config.ui.default new file mode 100644 --- /dev/null +++ b/GameDefinition/config.ui.default @@ -0,0 +1,26 @@ +; ; This is a commented out copy of the default UI settings config file +; ; that is embedded in the binary. +; ; A user config file can overrides these options. The game looks for it at +; ; ~/.LambdaHack/config.ui.ini (or a similar path, depending on the OS). +; ; Warning: options are case-sensitive and only ';' for comments is permitted. + +; [extra_commands] +; ; Handy shorthands with Vi keys: +; Macro_1 = ("comma", (CmdItem, Macro "" ["g"])) +; Macro_2 = ("period", (CmdMove, Macro "" ["KP_Begin"])) + +; [hero_names] +; HeroName_0 = Haskell Alvin +; HeroName_1 = Alonzo Barkley +; HeroName_2 = Ines Galenti +; HeroName_3 = Ernst Abraham +; HeroName_4 = Samuel Saunders +; HeroName_5 = Roger Robin + +; [ui] +; font = "Terminus,Monospace normal normal normal normal 12" +; historyMax = 5000 +; maxFps = 15 +; noAnim = False +; runStopMsgs = False +[dummy] diff --git a/GameDefinition/scores b/GameDefinition/scores new file mode 100644 Binary files /dev/null and b/GameDefinition/scores differ diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ -Copyright (c) 2008--2013 Andres Loeh -Copyright (c) 2010--2013 Mikolaj Konarski +Copyright (c) 2008--2014 Andres Loeh +Copyright (c) 2010--2014 Mikolaj Konarski All rights reserved. diff --git a/LambdaHack.cabal b/LambdaHack.cabal --- a/LambdaHack.cabal +++ b/LambdaHack.cabal @@ -1,5 +1,5 @@ name: LambdaHack -version: 0.2.10.6 +version: 0.2.12 synopsis: A roguelike game engine in early and active development description: This is an alpha release of LambdaHack, a game engine library for roguelike games @@ -15,20 +15,11 @@ but the fundamental source of flexibility lies in the strict and type-safe separation of code and content and of clients (human and AI-controlled) and server. - . - This is a minor release, primarily intended to fix broken - vty an curses frontends and an unrelated game crash, as well as - broken builds on hackage and travis. Changes since 0.2.10 - are mostly unrelated to gameplay: overhauled dungeon generation - code and the use of the external library assert-failure - for expressing assertions and error messages. - Upcoming features: new and improved frontends, improved AI - (pathfinding, autoexplore, better ranged combat), dynamic - light sources, explosions, player action undo/redo, completely - redesigned UI. Long term goals are focused on procedural - content generation and include in-game content creation, - auto-balancing and persistent content modification - based on player behaviour. + Please see the changelog file for recent improvements + and the issue tracker for short-term plans. Long term vision + revolves around procedural content generation and includes + in-game content creation, auto-balancing and persistent + content modification based on player behaviour. . A larger game that depends on the LambdaHack library is Allure of the Stars, available from @@ -49,10 +40,11 @@ bug-reports: http://github.com/kosmikus/LambdaHack/issues license: BSD3 license-file: LICENSE -tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.7 -data-files: config.rules.default, config.ui.default, scores -extra-source-files: LICENSE, CREDITS, changelog, PLAYING.md, README.md, - Makefile, MainMenu.ascii, .travis.yml +tested-with: GHC == 7.6.3, GHC == 7.8 +data-files: GameDefinition/config.ui.default, + GameDefinition/scores +extra-source-files: GameDefinition/PLAYING.md, GameDefinition/MainMenu.ascii, + README.md, LICENSE, CREDITS, changelog, Makefile author: Andres Loeh, Mikolaj Konarski maintainer: Mikolaj Konarski category: Game Engine, Game @@ -81,7 +73,6 @@ Game.LambdaHack.Client.ClientSem, Game.LambdaHack.Client.Config, Game.LambdaHack.Client.Draw, - Game.LambdaHack.Client.HumanCmd, Game.LambdaHack.Client.HumanGlobal, Game.LambdaHack.Client.HumanLocal, Game.LambdaHack.Client.HumanSem, @@ -100,22 +91,23 @@ Game.LambdaHack.Common.AtomicSem, Game.LambdaHack.Common.ClientCmd, Game.LambdaHack.Common.Color, - Game.LambdaHack.Common.ConfigIO, Game.LambdaHack.Common.ContentDef, Game.LambdaHack.Common.Effect, Game.LambdaHack.Common.Faction, Game.LambdaHack.Common.Feature, Game.LambdaHack.Common.Flavour, Game.LambdaHack.Common.HighScore, + Game.LambdaHack.Common.HumanCmd, Game.LambdaHack.Common.Item, + Game.LambdaHack.Common.ItemFeature, Game.LambdaHack.Common.Key, Game.LambdaHack.Common.Kind, Game.LambdaHack.Common.Level, Game.LambdaHack.Common.Misc, Game.LambdaHack.Common.Msg, Game.LambdaHack.Common.Perception, + Game.LambdaHack.Common.PointArray, Game.LambdaHack.Common.Point, - Game.LambdaHack.Common.PointXY, Game.LambdaHack.Common.Random, Game.LambdaHack.Common.Save, Game.LambdaHack.Common.ServerCmd, @@ -123,7 +115,6 @@ Game.LambdaHack.Common.Tile, Game.LambdaHack.Common.Time, Game.LambdaHack.Common.Vector, - Game.LambdaHack.Common.VectorXY, Game.LambdaHack.Content.ActorKind, Game.LambdaHack.Content.CaveKind, Game.LambdaHack.Content.FactionKind, @@ -140,7 +131,6 @@ Game.LambdaHack.Server.Action.ActionClass, Game.LambdaHack.Server.Action.ActionType, Game.LambdaHack.Server.AtomicSemSer, - Game.LambdaHack.Server.Config, Game.LambdaHack.Server.DungeonGen, Game.LambdaHack.Server.DungeonGen.Area Game.LambdaHack.Server.DungeonGen.AreaRnd, @@ -161,8 +151,7 @@ Game.LambdaHack.Utils.LQueue, Game.LambdaHack.Utils.Thread other-modules: Paths_LambdaHack - build-depends: ConfigFile >= 1.1.1 && < 2, - array >= 0.3.0.3 && < 1, + build-depends: array >= 0.3.0.3 && < 1, assert-failure >= 0.1 && < 1, base >= 4 && < 5, binary >= 0.7 && < 1, @@ -173,17 +162,20 @@ enummapset-th >= 0.6.0.0 && < 1, filepath >= 1.2.0.1 && < 2, ghc-prim >= 0.2, - hashable >= 1.2 && < 2, + hashable >= 1.1.2.5 && < 2, + hsini >= 0.2 && < 2, keys >= 3 && < 4, miniutter >= 0.4.1 && < 2, mtl >= 2.0.1 && < 3, old-time >= 1.0.0.7 && < 2, - pretty-show >= 1.6 && < 1.6.2, + pretty-show >= 1.6 && < 2, random >= 1.0.1 && < 2, stm >= 2.4 && < 3, text >= 0.11.2.3 && < 2, transformers >= 0.3 && < 1, unordered-containers >= 0.2.3 && < 1, + vector >= 0.10 && < 1, + vector-binary-instances >= 0.2 && < 1, zlib >= 0.5.3.1 && < 1 default-language: Haskell2010 @@ -206,7 +198,7 @@ cpp-options: -DCURSES } else { if flag(vty) { other-modules: Game.LambdaHack.Frontend.Vty - build-depends: vty >= 4.7.0.6 + build-depends: vty >= 4.7.0.6 && < 5 cpp-options: -DVTY } else { other-modules: Game.LambdaHack.Frontend.Gtk @@ -214,7 +206,7 @@ } } executable LambdaHack - hs-source-dirs: LambdaHack + hs-source-dirs: GameDefinition main-is: Main.hs other-modules: Content.ActorKind, Content.CaveKind, @@ -228,7 +220,6 @@ build-depends: LambdaHack, template-haskell >= 2.6 && < 3, - ConfigFile >= 1.1.1 && < 2, array >= 0.3.0.3 && < 1, assert-failure >= 0.1 && < 1, base >= 4 && < 5, @@ -240,16 +231,20 @@ enummapset-th >= 0.6.0.0 && < 1, filepath >= 1.2.0.1 && < 2, ghc-prim >= 0.2, - hashable >= 1.2 && < 2, + hashable >= 1.1.2.5 && < 2, + hsini >= 0.2 && < 2, keys >= 3 && < 4, miniutter >= 0.4.1 && < 2, mtl >= 2.0.1 && < 3, old-time >= 1.0.0.7 && < 2, + pretty-show >= 1.6 && < 2, random >= 1.0.1 && < 2, stm >= 2.4 && < 3, text >= 0.11.2.3 && < 2, transformers >= 0.3 && < 1, unordered-containers >= 0.2.3 && < 1, + vector >= 0.10 && < 1, + vector-binary-instances >= 0.2 && < 1, zlib >= 0.5.3.1 && < 1 default-language: Haskell2010 diff --git a/LambdaHack/Content/ActorKind.hs b/LambdaHack/Content/ActorKind.hs deleted file mode 100644 --- a/LambdaHack/Content/ActorKind.hs +++ /dev/null @@ -1,88 +0,0 @@ --- | Monsters and heroes for LambdaHack. -module Content.ActorKind ( cdefs ) where - -import Game.LambdaHack.Common.Ability -import Game.LambdaHack.Common.Color -import Game.LambdaHack.Common.ContentDef -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Content.ActorKind - -cdefs :: ContentDef ActorKind -cdefs = ContentDef - { getSymbol = asymbol - , getName = aname - , getFreq = afreq - , validate = avalidate - , content = - [hero, projectile, eye, fastEye, nose] - } -hero, projectile, eye, fastEye, nose :: ActorKind - -hero = ActorKind - { asymbol = '@' - , aname = "hero" - , afreq = [("hero", 1)] - , acolor = BrWhite -- modified if many hero factions - , ahp = rollDice 50 1 - , aspeed = toSpeed 2 - , asight = True - , asmell = False - , aiq = 15 -- higher that that leads to looping movement - , aregen = 500 - , acanDo = [minBound..maxBound] - } - -projectile = ActorKind -- includes homing missiles - { asymbol = '*' - , aname = "projectile" - , afreq = [("projectile", 1)] -- Does not appear randomly in the dungeon. - , acolor = BrWhite - , ahp = rollDice 0 0 - , aspeed = toSpeed 0 - , asight = False - , asmell = False - , aiq = 0 - , aregen = maxBound - , acanDo = [Track] - } - -eye = ActorKind - { asymbol = 'e' - , aname = "reducible eye" - , afreq = [("monster", 60), ("horror", 60)] - , acolor = BrRed - , ahp = rollDice 7 4 - , aspeed = toSpeed 2 - , asight = True - , asmell = False - , aiq = 8 - , aregen = 100 - , acanDo = [minBound..maxBound] - } -fastEye = ActorKind - { asymbol = 'e' - , aname = "super-fast eye" - , afreq = [("monster", 15), ("horror", 15)] - , acolor = BrBlue - , ahp = rollDice 1 4 - , aspeed = toSpeed 4 - , asight = True - , asmell = False - , aiq = 12 - , aregen = 5 -- Regenerates fast (at max HP most of the time!). - , acanDo = [minBound..maxBound] - } -nose = ActorKind - { asymbol = 'n' - , aname = "point-free nose" - , afreq = [("monster", 20), ("horror", 20)] - , acolor = Green - , ahp = rollDice 17 2 - , aspeed = toSpeed 1.8 - , asight = False - , asmell = True - , aiq = 0 - , aregen = 100 - , acanDo = [minBound..maxBound] - } diff --git a/LambdaHack/Content/CaveKind.hs b/LambdaHack/Content/CaveKind.hs deleted file mode 100644 --- a/LambdaHack/Content/CaveKind.hs +++ /dev/null @@ -1,116 +0,0 @@ --- | Cave layouts for LambdaHack. -module Content.CaveKind ( cdefs ) where - -import Data.Ratio - -import Game.LambdaHack.Common.ContentDef -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Random as Random -import Game.LambdaHack.Content.CaveKind - -cdefs :: ContentDef CaveKind -cdefs = ContentDef - { getSymbol = csymbol - , getName = cname - , getFreq = cfreq - , validate = cvalidate - , content = - [rogue, arena, empty, noise, combat] - } -rogue, arena, empty, noise, combat :: CaveKind - -rogue = CaveKind - { csymbol = '$' - , cname = "A maze of twisty passages" - , cfreq = [("dng", 100), ("caveRogue", 1)] - , cxsize = fst normalLevelBound + 1 - , cysize = snd normalLevelBound + 1 - , cgrid = rollDiceXY [(3, 2)] [(1, 2), (2, 1)] - , cminPlaceSize = rollDiceXY [(2, 2), (2, 1)] [(4, 1)] - , cmaxPlaceSize = rollDiceXY [(fst normalLevelBound, 1)] - [(snd normalLevelBound, 1)] - , cdarkChance = rollDeep (1, 54) (0, 0) - , cnightChance = intToDeep 100 - , cauxConnects = 1%3 - , cmaxVoid = 1%6 - , cminStairDist = 30 - , cdoorChance = 1%2 - , copenChance = 1%10 - , chidden = 8 - , citemNum = rollDice 7 2 - , citemFreq = [(70, "useful"), (30, "treasure")] - , cdefTile = "fillerWall" - , cdarkCorTile = "floorCorridorDark" - , clitCorTile = "floorCorridorDark" - , cfillerTile = "fillerWall" - , cdarkLegendTile = "darkLegend" - , clitLegendTile = "litLegend" - } -arena = rogue - { csymbol = 'A' - , cname = "Underground city" - , cfreq = [("dng", 30), ("caveArena", 1)] - , cgrid = rollDiceXY [(2, 2)] [(2, 2)] - , cminPlaceSize = rollDiceXY [(2, 2), (3, 1)] [(4, 1)] - , cdarkChance = rollDeep (1, 80) (1, 60) - , cnightChance = intToDeep 0 - , cmaxVoid = 1%3 - , chidden = 1000 - , citemNum = rollDice 5 2 -- few rooms - , cdefTile = "arenaSet" - , cdarkCorTile = "pathDark" - , clitCorTile = "pathLit" - } -empty = rogue - { csymbol = '.' - , cname = "Tall cavern" - , cfreq = [("dng", 20), ("caveEmpty", 1)] - , cgrid = rollDiceXY [(1, 2), (1, 1)] [(1, 1)] - , cminPlaceSize = rollDiceXY [(10, 1)] [(10, 1)] - , cmaxPlaceSize = rollDiceXY [(fst normalLevelBound * 3 `div` 5, 1)] - [(snd normalLevelBound * 3 `div` 5, 1)] - , cdarkChance = rollDeep (1, 80) (1, 80) - , cnightChance = intToDeep 0 - , cauxConnects = 1 - , cmaxVoid = 1%2 - , cminStairDist = 50 - , chidden = 1000 - , citemNum = rollDice 8 2 -- whole floor strewn with treasure - , cdefTile = "emptySet" - , cdarkCorTile = "pathDark" - , clitCorTile = "floorArenaLit" - } -noise = rogue - { csymbol = '!' - , cname = "Glittering cave" - , cfreq = [("dng", 20), ("caveNoise", 1)] - , cgrid = rollDiceXY [(2, 2)] [(1, 2), (1, 1)] - , cminPlaceSize = rollDiceXY [(3, 2), (2, 1)] [(5, 1)] - , cdarkChance = rollDeep (1, 80) (1, 40) - , cnightChance = rollDeep (1, 40) (1, 40) - , cmaxVoid = 0 - , chidden = 1000 - , citemNum = rollDice 4 2 -- fewer rooms - , cdefTile = "noiseSet" - , cdarkCorTile = "pathDark" - , clitCorTile = "pathLit" - } -combat = rogue - { csymbol = 'C' - , cname = "Combat arena" - , cfreq = [("caveCombat", 1)] - , cgrid = rollDiceXY [(2, 2), (3, 1)] [(1, 2), (2, 1)] - , cminPlaceSize = rollDiceXY [(3, 1)] [(3, 1)] - , cmaxPlaceSize = rollDiceXY [(5, 1)] [(5, 1)] - , cdarkChance = intToDeep 100 - , cnightChance = rollDeep (1, 67) (0, 0) - , chidden = 1000 - , cauxConnects = 0 - , cdoorChance = 1 - , copenChance = 0 - , citemNum = rollDice 12 2 - , citemFreq = [(100, "useful")] - , cdefTile = "combatSet" - , cdarkCorTile = "pathLit" -- for now, let paths give off light - , clitCorTile = "floorArenaLit" - } diff --git a/LambdaHack/Content/FactionKind.hs b/LambdaHack/Content/FactionKind.hs deleted file mode 100644 --- a/LambdaHack/Content/FactionKind.hs +++ /dev/null @@ -1,55 +0,0 @@ --- | The type of kinds of game factions (heroes, enemies, NPCs, etc.) --- for LambdaHack. -module Content.FactionKind ( cdefs ) where - -import Game.LambdaHack.Common.Ability -import Game.LambdaHack.Common.ContentDef -import Game.LambdaHack.Content.FactionKind - -cdefs :: ContentDef FactionKind -cdefs = ContentDef - { getSymbol = fsymbol - , getName = fname - , getFreq = ffreq - , validate = fvalidate - , content = - [hero, monster, horror] - } -hero, monster, horror :: FactionKind - -hero = FactionKind - { fsymbol = '@' - , fname = "hero" - , ffreq = [("hero", 1)] - , fAbilityLeader = allAbilities - , fAbilityOther = meleeAdjacent - } - -monster = FactionKind - { fsymbol = 'm' - , fname = "monster" - , ffreq = [("monster", 1), ("spawn", 50), ("summon", 50)] - , fAbilityLeader = allAbilities - , fAbilityOther = allAbilities - } - -horror = FactionKind - { fsymbol = 'h' - , fname = "horror" - , ffreq = [("horror", 1), ("summon", 50)] - , fAbilityLeader = allAbilities - , fAbilityOther = allAbilities - } - - -_noAbility, _onlyFollowTrack, meleeAdjacent, _meleeAndRanged, allAbilities :: [Ability] - -_noAbility = [] -- not even projectiles will fly - -_onlyFollowTrack = [Track] -- projectiles enabled - -meleeAdjacent = [Track, Melee] - -_meleeAndRanged = [Track, Melee, Ranged] -- melee and reaction fire - -allAbilities = [minBound..maxBound] diff --git a/LambdaHack/Content/ItemKind.hs b/LambdaHack/Content/ItemKind.hs deleted file mode 100644 --- a/LambdaHack/Content/ItemKind.hs +++ /dev/null @@ -1,206 +0,0 @@ --- | Weapons and treasure for LambdaHack. -module Content.ItemKind ( cdefs ) where - -import Game.LambdaHack.Common.Color -import Game.LambdaHack.Common.ContentDef -import Game.LambdaHack.Common.Effect -import Game.LambdaHack.Common.Flavour -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Content.ItemKind - -cdefs :: ContentDef ItemKind -cdefs = ContentDef - { getSymbol = isymbol - , getName = iname - , getFreq = ifreq - , validate = ivalidate - , content = - [amulet, dart, gem1, gem2, gem3, currency, harpoon, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand1, wand2, fist, foot, tentacle] - } -amulet, dart, gem1, gem2, gem3, currency, harpoon, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand1, wand2, fist, foot, tentacle :: ItemKind - -gem, potion, scroll, wand :: ItemKind -- generic templates - --- castDeep (aDb, xDy) = castDice aDb + (lvl - 1) * castDice xDy / (depth - 1) - -amulet = ItemKind - { isymbol = '"' - , iname = "amulet" - , ifreq = [("useful", 6)] - , iflavour = zipFancy [BrGreen] - , ieffect = Regeneration (rollDeep (2, 3) (1, 10)) - , icount = intToDeep 1 - , iverbApply = "tear down" - , iverbProject = "cast" - , iweight = 30 - , itoThrow = -50 -- not dense enough - } -dart = ItemKind - { isymbol = '|' - , iname = "dart" - , ifreq = [("useful", 20)] - , iflavour = zipPlain [Cyan] - , ieffect = Hurt (rollDice 1 1) (rollDeep (1, 2) (1, 2)) - , icount = rollDeep (3, 3) (0, 0) - , iverbApply = "snap" - , iverbProject = "hurl" - , iweight = 50 - , itoThrow = 0 -- a cheap dart - } -gem = ItemKind - { isymbol = '*' - , iname = "gem" - , ifreq = [("treasure", 20)] -- x3, but rare on shallow levels - , iflavour = zipPlain brightCol -- natural, so not fancy - , ieffect = NoEffect - , icount = intToDeep 0 - , iverbApply = "crush" - , iverbProject = "toss" - , iweight = 50 - , itoThrow = 0 - } -gem1 = gem - { icount = rollDeep (0, 0) (1, 1) -- appears on max depth - } -gem2 = gem - { icount = rollDeep (0, 0) (1, 2) -- appears halfway - } -gem3 = gem - { icount = rollDeep (0, 0) (1, 3) -- appears early - } -currency = ItemKind - { isymbol = '$' - , iname = "gold piece" - , ifreq = [("treasure", 20), ("currency", 1)] - , iflavour = zipPlain [BrYellow] - , ieffect = NoEffect - , icount = rollDeep (0, 0) (10, 10) -- appears on lvl 2 - , iverbApply = "grind" - , iverbProject = "toss" - , iweight = 31 - , itoThrow = 0 - } -harpoon = ItemKind - { isymbol = '|' - , iname = "harpoon" - , ifreq = [("useful", 25)] - , iflavour = zipPlain [Brown] - , ieffect = Hurt (rollDice 1 2) (rollDeep (1, 2) (2, 2)) - , icount = rollDeep (0, 0) (2, 2) - , iverbApply = "break up" - , iverbProject = "hurl" - , iweight = 4000 - , itoThrow = 0 -- cheap but deadly - } -potion = ItemKind - { isymbol = '!' - , iname = "potion" - , ifreq = [("useful", 15)] - , iflavour = zipFancy stdCol - , ieffect = NoEffect - , icount = intToDeep 1 - , iverbApply = "gulp down" - , iverbProject = "lob" - , iweight = 200 - , itoThrow = -50 -- oily, bad grip - } -potion1 = potion - { ifreq = [("useful", 5)] - , ieffect = ApplyPerfume - } -potion2 = potion - { ieffect = Heal 5 - } -potion3 = potion - { ifreq = [("useful", 5)] - , ieffect = Heal (-5) - } -ring = ItemKind - { isymbol = '=' - , iname = "ring" - , ifreq = [] -- [("useful", 10)] -- TODO: make it useful - , iflavour = zipPlain [White] - , ieffect = Searching (rollDeep (1, 6) (3, 2)) - , icount = intToDeep 1 - , iverbApply = "squeeze down" - , iverbProject = "toss" - , iweight = 15 - , itoThrow = 0 - } -scroll = ItemKind - { isymbol = '?' - , iname = "scroll" - , ifreq = [("useful", 4)] - , iflavour = zipFancy darkCol -- arcane and old - , ieffect = NoEffect - , icount = intToDeep 1 - , iverbApply = "decipher" - , iverbProject = "lob" - , iweight = 50 - , itoThrow = -75 -- bad shape, even rolled up - } -scroll1 = scroll - { ieffect = CallFriend 1 - , ifreq = [("useful", 2)] - } -scroll2 = scroll - { ieffect = Summon 1 - } -scroll3 = scroll - { ieffect = Ascend (-1) - } -sword = ItemKind - { isymbol = ')' - , iname = "sword" - , ifreq = [("useful", 40)] - , iflavour = zipPlain [BrCyan] - , ieffect = Hurt (rollDice 3 1) (rollDeep (1, 2) (4, 2)) - , icount = intToDeep 1 - , iverbApply = "hit" - , iverbProject = "heave" - , iweight = 2000 - , itoThrow = -50 -- ensuring it hits with the tip costs speed - } -wand = ItemKind - { isymbol = '/' - , iname = "wand" - , ifreq = [("useful", 10)] - , iflavour = zipFancy brightCol - , ieffect = NoEffect - , icount = intToDeep 1 - , iverbApply = "snap" - , iverbProject = "zap" - , iweight = 300 - , itoThrow = 25 -- magic - } -wand1 = wand - { ieffect = Dominate - } -wand2 = wand - { ifreq = [("useful", 3)] - , ieffect = Heal (-25) - } -fist = sword - { isymbol = '@' - , iname = "fist" - , ifreq = [("hth", 1), ("unarmed", 100)] - , ieffect = Hurt (rollDice 3 1) (intToDeep 0) - , iverbApply = "punch" - , iverbProject = "ERROR, please report: iverbProject fist" - } -foot = sword - { isymbol = '@' - , iname = "foot" - , ifreq = [("hth", 1), ("unarmed", 50)] - , ieffect = Hurt (rollDice 3 1) (intToDeep 0) - , iverbApply = "kick" - , iverbProject = "ERROR, please report: iverbProject foot" - } -tentacle = sword - { isymbol = 'S' - , iname = "tentacle" - , ifreq = [("hth", 1), ("monstrous", 100)] - , ieffect = Hurt (rollDice 3 1) (intToDeep 0) - , iverbApply = "hit" - , iverbProject = "ERROR, please report: iverbProject tentacle" - } diff --git a/LambdaHack/Content/ModeKind.hs b/LambdaHack/Content/ModeKind.hs deleted file mode 100644 --- a/LambdaHack/Content/ModeKind.hs +++ /dev/null @@ -1,259 +0,0 @@ --- | The type of kinds of game modes for LambdaHack. -module Content.ModeKind ( cdefs ) where - -import qualified Data.EnumMap.Strict as EM - -import Game.LambdaHack.Common.ContentDef -import Game.LambdaHack.Content.ModeKind - -cdefs :: ContentDef ModeKind -cdefs = ContentDef - { getSymbol = msymbol - , getName = mname - , getFreq = mfreq - , validate = mvalidate - , content = - [campaign, skirmish, pvp, coop, defense, screensaver, testCoop, testDefense, peekCampaign, peekSkirmish] - } -campaign, skirmish, pvp, coop, defense, screensaver, testCoop, testDefense, peekCampaign, peekSkirmish :: ModeKind - -campaign = ModeKind - { msymbol = 'r' - , mname = "campaign" - , mfreq = [("campaign", 1)] - , mplayers = playersCampaign - , mcaves = cavesCampaign - } - -skirmish = ModeKind - { msymbol = 's' - , mname = "skirmish" - , mfreq = [("skirmish", 1)] - , mplayers = playersSkirmish - , mcaves = cavesCombat - } - -pvp = ModeKind - { msymbol = 'p' - , mname = "PvP" - , mfreq = [("PvP", 1)] - , mplayers = playersPvP - , mcaves = cavesCombat - } - -coop = ModeKind - { msymbol = 'c' - , mname = "Coop" - , mfreq = [("Coop", 1)] - , mplayers = playersCoop - , mcaves = cavesCampaign - } - -defense = ModeKind - { msymbol = 'd' - , mname = "defense" - , mfreq = [("defense", 1)] - , mplayers = playersDefense - , mcaves = cavesDefense - } - -screensaver = ModeKind - { msymbol = 'n' - , mname = "screensaver" - , mfreq = [("screensaver", 1)] - , mplayers = playersScreensaver - , mcaves = cavesScreensaver - } - -testCoop = ModeKind - { msymbol = 't' - , mname = "testCoop" - , mfreq = [("testCoop", 1)] - , mplayers = playersTestCoop - , mcaves = cavesScreensaver - } - -testDefense = ModeKind - { msymbol = 'u' - , mname = "testDefense" - , mfreq = [("testDefense", 1)] - , mplayers = playersTestDefense - , mcaves = cavesDefense - } - -peekCampaign = ModeKind - { msymbol = 'e' - , mname = "peekCampaign" - , mfreq = [("peekCampaign", 1)] - , mplayers = playersPeekCampaign - , mcaves = cavesCampaign - } - -peekSkirmish = ModeKind - { msymbol = 'f' - , mname = "peekSkirmish" - , mfreq = [("peekSkirmish", 1)] - , mplayers = playersPeekSkirmish - , mcaves = cavesCombat - } - - -playersCampaign, playersSkirmish, playersPvP, playersCoop, playersDefense, playersScreensaver, playersTestCoop, playersTestDefense, playersPeekCampaign, playersPeekSkirmish :: Players - -playersCampaign = Players - { playersList = [ playerHero {playerInitial = 1} - , playerMonster ] - , playersEnemy = [("Adventuring Party", "Monster Hive")] - , playersAlly = [] } - -playersSkirmish = Players - { playersList = [ playerHero {playerName = "White"} - , playerAntiHero {playerName = "Purple"} - , playerHorror ] - , playersEnemy = [ ("White", "Purple") - , ("White", "Horror Den") - , ("Purple", "Horror Den") ] - , playersAlly = [] } - -playersPvP = Players - { playersList = [ playerHero {playerName = "Red"} - , playerHero {playerName = "Blue"} - , playerHorror ] - , playersEnemy = [ ("Red", "Blue") - , ("Red", "Horror Den") - , ("Blue", "Horror Den") ] - , playersAlly = [] } - -playersCoop = Players - { playersList = [ playerHero { playerName = "Coral" - , playerInitial = 1 } - , playerHero { playerName = "Amber" - , playerInitial = 1 } - , playerMonster ] - , playersEnemy = [ ("Coral", "Monster Hive") - , ("Amber", "Monster Hive") ] - , playersAlly = [("Coral", "Amber")] } - -playersDefense = Players - { playersList = [ playerMonster { playerInitial = 1 - , playerEntry = toEnum (-1) - , playerAiLeader = False - , playerHuman = True - , playerUI = True } - , playerAntiHero {playerName = "Green"} - , playerAntiHero {playerName = "Yellow"} - , playerAntiHero {playerName = "Cyan"} ] - , playersEnemy = [ ("Green", "Monster Hive") - , ("Yellow", "Monster Hive") - , ("Cyan", "Monster Hive") ] - , playersAlly = [ ("Green", "Yellow") - , ("Green", "Cyan") - , ("Yellow", "Cyan") ] } - -playersScreensaver = Players - { playersList = [ playerHero { playerInitial = 5 - , playerAiLeader = True - , playerHuman = False } - , playerMonster ] - , playersEnemy = [("Adventuring Party", "Monster Hive")] - , playersAlly = [] } - -playersTestCoop = Players - { playersList = [ playerHero { playerName = "Coral" - , playerAiLeader = True - , playerHuman = False } - , playerHero { playerName = "Amber" - , playerAiLeader = True - , playerHuman = False } - , playerMonster ] - , playersEnemy = [ ("Coral", "Monster Hive") - , ("Amber", "Monster Hive") ] - , playersAlly = [("Coral", "Amber")] } - -playersTestDefense = Players - { playersList = [ playerMonster { playerInitial = 1 - , playerEntry = toEnum (-1) - , playerUI = True } - , playerAntiHero {playerName = "Green"} - , playerAntiHero {playerName = "Yellow"} - , playerAntiHero {playerName = "Cyan"} ] - , playersEnemy = [ ("Green", "Monster Hive") - , ("Yellow", "Monster Hive") - , ("Cyan", "Monster Hive") ] - , playersAlly = [ ("Green", "Yellow") - , ("Green", "Cyan") - , ("Yellow", "Cyan") ] } - -playersPeekCampaign = Players - { playersList = [ playerHero {playerInitial = 1} - , playerMonster {playerUI = True} ] - , playersEnemy = [("Adventuring Party", "Monster Hive")] - , playersAlly = [] } - -playersPeekSkirmish = Players - { playersList = [ playerHero {playerName = "White"} - , playerAntiHero { playerName = "Purple" - , playerUI = True } - , playerHorror ] - , playersEnemy = [ ("White", "Purple") - , ("White", "Horror Den") - , ("Purple", "Horror Den") ] - , playersAlly = [] } - - -playerHero, playerAntiHero, playerMonster, playerHorror :: Player - -playerHero = Player - { playerName = "Adventuring Party" - , playerFaction = "hero" - , playerEntry = toEnum (-1) - , playerInitial = 3 - , playerAiLeader = False - , playerAiOther = True - , playerHuman = True - , playerUI = True - } - -playerAntiHero = playerHero - { playerAiLeader = True - , playerHuman = False - , playerUI = False - } - -playerMonster = Player - { playerName = "Monster Hive" - , playerFaction = "monster" - , playerEntry = toEnum (-3) - , playerInitial = 5 - , playerAiLeader = True - , playerAiOther = True - , playerHuman = False - , playerUI = False - } - -playerHorror = Player - { playerName = "Horror Den" - , playerFaction = "horror" - , playerEntry = toEnum (-1) - , playerInitial = 0 - , playerAiLeader = True - , playerAiOther = True - , playerHuman = False - , playerUI = False - } - - -cavesCampaign, cavesCombat, cavesDefense, cavesScreensaver :: Caves - -cavesCampaign = EM.fromList [ (toEnum (-1), ("caveRogue", Just True)) - , (toEnum (-2), ("caveRogue", Nothing)) - , (toEnum (-3), ("caveEmpty", Nothing)) - , (toEnum (-10), ("caveNoise", Nothing))] - -cavesCombat = EM.fromList [(toEnum (-3), ("caveCombat", Nothing))] - -cavesDefense = EM.fromList [ (toEnum (-1), ("dng", Nothing)) - , (toEnum (-5), ("caveEmpty", Just False))] - -cavesScreensaver = EM.fromList [ (toEnum (-1), ("caveRogue", Nothing)) - , (toEnum (-10), ("caveNoise", Just False))] diff --git a/LambdaHack/Content/PlaceKind.hs b/LambdaHack/Content/PlaceKind.hs deleted file mode 100644 --- a/LambdaHack/Content/PlaceKind.hs +++ /dev/null @@ -1,71 +0,0 @@ --- | Rooms, halls and passages for LambdaHack. -module Content.PlaceKind ( cdefs ) where - -import Game.LambdaHack.Common.ContentDef -import Game.LambdaHack.Content.PlaceKind - -cdefs :: ContentDef PlaceKind -cdefs = ContentDef - { getSymbol = psymbol - , getName = pname - , getFreq = pfreq - , validate = pvalidate - , content = - [rect, pillar, pillarC, pillar3, colonnade, colonnadeW] - } -rect, pillar, pillarC, pillar3, colonnade, colonnadeW :: PlaceKind - -rect = PlaceKind -- Valid for any nonempty area, hence low frequency. - { psymbol = 'r' - , pname = "room" - , pfreq = [("rogue", 100)] - , pcover = CStretch - , pfence = FNone - , ptopLeft = [ "--" - , "|." - ] - } -pillar = PlaceKind - { psymbol = 'p' - , pname = "pillar room" - , pfreq = [("rogue", 1000)] -- larger rooms require support pillars - , pcover = CStretch - , pfence = FNone - , ptopLeft = [ "-----" - , "|...." - , "|.O.." - , "|...." - , "|...." - ] - } -pillarC = pillar - { ptopLeft = [ "-----" - , "|O..." - , "|...." - , "|...." - , "|...." - ] - } -pillar3 = pillar - { ptopLeft = [ "-----" - , "|&.O." - , "|...." - , "|O..." - , "|...." - ] - } -colonnade = PlaceKind - { psymbol = 'c' - , pname = "colonnade" - , pfreq = [("rogue", 500)] - , pcover = CAlternate - , pfence = FFloor - , ptopLeft = [ "O." - , ".O" - ] - } -colonnadeW = colonnade - { ptopLeft = [ "O." - , ".." - ] - } diff --git a/LambdaHack/Content/RuleKind.hs b/LambdaHack/Content/RuleKind.hs deleted file mode 100644 --- a/LambdaHack/Content/RuleKind.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} --- | Game rules and assorted game setup data for LambdaHack. -module Content.RuleKind ( cdefs ) where - -import Language.Haskell.TH.Syntax - --- Cabal -import qualified Paths_LambdaHack as Self (getDataFileName, version) - -import Game.LambdaHack.Common.ContentDef -import qualified Game.LambdaHack.Common.Feature as F -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Content.TileKind - -cdefs :: ContentDef RuleKind -cdefs = ContentDef - { getSymbol = rsymbol - , getName = rname - , getFreq = rfreq - , validate = ruvalidate - , content = - [standard] - } - -standard :: RuleKind -standard = RuleKind - { rsymbol = 's' - , rname = "standard LambdaHack ruleset" - , rfreq = [("standard", 100)] - -- Check whether one position is accessible from another. - -- Precondition: the two positions are next to each other. - -- Apart of checking the target tile, we forbid diagonal movement - -- to and from doors. - , raccessible = \ lxsize spos src tpos tgt -> - let getTo F.CloseTo{} = True - getTo _ = False - in F.Walkable `elem` tfeature tgt - && not ((any getTo (tfeature src) || - any getTo (tfeature tgt)) - && diagonal lxsize (displacement spos tpos)) - , rtitle = "LambdaHack" - , rpathsDataFile = Self.getDataFileName - , rpathsVersion = Self.version - , ritemMelee = ")" - , ritemRanged = "|" - -- Wasting weapons and armour would be too cruel to the player. - , ritemProject = "!?|/" - -- The strings containing the default configuration files, - -- included from files config.game.default and config.ui.default. - -- Warning: cabal does not detect that the config files are changed, - -- so touching them is needed to reinclude configs and recompile. - -- Note: consider code.haskell.org/~dons/code/compiled-constants - -- as soon as the config file grows very big. - , rcfgRulesDefault = $(do - qAddDependentFile "config.rules.default" - x <- qRunIO (readFile "config.rules.default") - lift x) - , rcfgUIDefault = $(do - qAddDependentFile "config.ui.default" - x <- qRunIO (readFile "config.ui.default") - lift x) - -- ASCII art for the Main Menu. Only pure 7-bit ASCII characters are - -- allowed. The picture should be exactly 24 rows by 80 columns, - -- plus an extra frame (of any characters) that is ignored. - -- For a different screen size, the picture is centered and the outermost - -- rows and columns cloned. When displayed in the Main Menu screen, - -- it's overwritten with the game version string and keybinding strings. - -- The game version string begins and ends with a space and is placed - -- in the very bottom right corner. The keybindings overwrite places - -- marked with 25 left curly brace signs '{' in a row. The sign is forbidden - -- everywhere else. A specific number of such places with 25 left braces - -- are required, at most one per row, and all are overwritten - -- with text that is flushed left and padded with spaces. - -- The Main Menu is displayed dull white on black. - -- TODO: Show highlighted keybinding in inverse video or bright white on grey - -- background. The spaces that pad keybindings are not highlighted. - , rmainMenuArt = $(do - qAddDependentFile "MainMenu.ascii" - x <- qRunIO (readFile "MainMenu.ascii") - lift x) - } diff --git a/LambdaHack/Content/TileKind.hs b/LambdaHack/Content/TileKind.hs deleted file mode 100644 --- a/LambdaHack/Content/TileKind.hs +++ /dev/null @@ -1,307 +0,0 @@ --- | Terrain tiles for LambdaHack. -module Content.TileKind ( cdefs ) where - -import Game.LambdaHack.Common.Color -import Game.LambdaHack.Common.ContentDef -import qualified Game.LambdaHack.Common.Effect as Effect -import Game.LambdaHack.Common.Feature -import Game.LambdaHack.Content.TileKind - -cdefs :: ContentDef TileKind -cdefs = ContentDef - { getSymbol = tsymbol - , getName = tname - , getFreq = tfreq - , validate = tvalidate - , content = - [wall, hardRock, pillar, pillarCache, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpDark, stairsUpLit, stairsDark, stairsLit, stairsDownDark, stairsDownLit, escapeUpDark, escapeUpLit, escapeDownDark, escapeDownLit, unknown, floorCorridorLit, floorCorridorDark, floorArenaLit, floorArenaDark, floorItemLit, floorItemDark, floorActorItemLit, floorActorItemDark, floorRedDark, floorBlueDark, floorGreenDark, floorBrownDark, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit] - } -wall, hardRock, pillar, pillarCache, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpDark, stairsUpLit, stairsDark, stairsLit, stairsDownDark, stairsDownLit, escapeUpDark, escapeUpLit, escapeDownDark, escapeDownLit, unknown, floorCorridorLit, floorCorridorDark, floorArenaLit, floorArenaDark, floorItemLit, floorItemDark, floorActorItemLit, floorActorItemDark, floorRedDark, floorBlueDark, floorGreenDark, floorBrownDark, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit :: TileKind - -wall = TileKind - { tsymbol = ' ' - , tname = "bedrock" - , tfreq = [("fillerWall", 1), ("litLegend", 100), ("darkLegend", 100)] - , tcolor = BrWhite - , tcolor2 = defFG - , tfeature = [] - } -hardRock = TileKind - { tsymbol = ' ' - , tname = "impenetrable bedrock" - , tfreq = [("outer fence", 1)] - , tcolor = BrBlack - , tcolor2 = BrBlack - , tfeature = [Impenetrable] - } -pillar = TileKind - { tsymbol = 'O' - , tname = "rock" - , tfreq = [ ("cachable", 70) - , ("litLegend", 100), ("darkLegend", 100) - , ("noiseSet", 55), ("combatSet", 3) ] - , tcolor = BrWhite - , tcolor2 = defFG - , tfeature = [] - } -pillarCache = TileKind - { tsymbol = '&' - , tname = "cache" - , tfreq = [ ("cachable", 30) - , ("litLegend", 100), ("darkLegend", 100) ] - , tcolor = BrWhite - , tcolor2 = defFG - , tfeature = [Cause $ Effect.CreateItem 1, ChangeTo "cachable"] - } -tree = TileKind - { tsymbol = 'O' - , tname = "tree" - , tfreq = [("combatSet", 8)] - , tcolor = BrGreen - , tcolor2 = Green - , tfeature = [] - } -wallV = TileKind - { tsymbol = '|' - , tname = "granite wall" - , tfreq = [("litLegend", 100), ("darkLegend", 100)] - , tcolor = BrWhite - , tcolor2 = defFG - , tfeature = [HideAs "suspect vertical wall"] - } -wallSuspectV = TileKind - { tsymbol = '|' - , tname = "moldy wall" - , tfreq = [("suspect vertical wall", 1)] - , tcolor = BrWhite - , tcolor2 = defFG - , tfeature = [ Suspect - , RevealAs "vertical closed door" - ] - } -doorClosedV = TileKind - { tsymbol = '+' - , tname = "closed door" - , tfreq = [("vertical closed door", 1)] - , tcolor = Brown - , tcolor2 = BrBlack - , tfeature = [ Exit - , OpenTo "vertical open door" - , HideAs "suspect vertical wall" - ] - } -doorOpenV = TileKind - { tsymbol = '-' - , tname = "open door" - , tfreq = [("vertical open door", 1)] - , tcolor = Brown - , tcolor2 = BrBlack - , tfeature = [ Walkable, Clear, Exit - , CloseTo "vertical closed door" - ] - } -wallH = TileKind - { tsymbol = '-' - , tname = "granite wall" - , tfreq = [("litLegend", 100), ("darkLegend", 100)] - , tcolor = BrWhite - , tcolor2 = defFG - , tfeature = [HideAs "suspect horizontal wall"] - } -wallSuspectH = TileKind - { tsymbol = '-' - , tname = "scratched wall" - , tfreq = [("suspect horizontal wall", 1)] - , tcolor = BrWhite - , tcolor2 = defFG - , tfeature = [ Suspect - , RevealAs "horizontal closed door" - ] - } -doorClosedH = TileKind - { tsymbol = '+' - , tname = "closed door" - , tfreq = [("horizontal closed door", 1)] - , tcolor = Brown - , tcolor2 = BrBlack - , tfeature = [ Exit - , OpenTo "horizontal open door" - , HideAs "suspect horizontal wall" - ] - } -doorOpenH = TileKind - { tsymbol = '|' - , tname = "open door" - , tfreq = [("horizontal open door", 1)] - , tcolor = Brown - , tcolor2 = BrBlack - , tfeature = [ Walkable, Clear, Exit - , CloseTo "horizontal closed door" - ] - } -stairsUpDark = TileKind - { tsymbol = '<' - , tname = "staircase up" - , tfreq = [("darkLegend", 100)] --- Disabled, because the yellow artificial light does not fit LambdaHack. --- , tcolor = BrYellow --- Dark room interior, OTOH, is fine: - , tcolor = BrWhite - , tcolor2 = BrBlack - , tfeature = [Walkable, Clear, Exit, Cause $ Effect.Ascend 1] - } -stairsUpLit = stairsUpDark - { tfreq = [("litLegend", 100)] - , tcolor = BrWhite - , tcolor2 = defFG - , tfeature = Lit : tfeature stairsUpDark - } -stairsDark = TileKind - { tsymbol = '>' - , tname = "staircase" - , tfreq = [("darkLegend", 100)] - , tcolor = BrCyan - , tcolor2 = Cyan -- TODO - , tfeature = [ Walkable, Clear, Exit - , Cause $ Effect.Ascend 1 - , Cause $ Effect.Ascend (-1) ] - } -stairsLit = stairsDark - { tfreq = [("litLegend", 100)] - , tcolor = BrCyan - , tcolor2 = Cyan -- TODO - , tfeature = Lit : tfeature stairsDark - } -stairsDownDark = TileKind - { tsymbol = '>' - , tname = "staircase down" - , tfreq = [("darkLegend", 100)] - , tcolor = BrWhite - , tcolor2 = BrBlack - , tfeature = [Walkable, Clear, Exit, Cause $ Effect.Ascend (-1)] - } -stairsDownLit = stairsDownDark - { tfreq = [("litLegend", 100)] - , tcolor = BrWhite - , tcolor2 = defFG - , tfeature = Lit : tfeature stairsDownDark - } -escapeUpDark = TileKind - { tsymbol = '<' - , tname = "exit trapdoor up" - , tfreq = [("darkLegend", 100)] - , tcolor = BrYellow - , tcolor2 = BrYellow - , tfeature = [Walkable, Clear, Exit, Cause Effect.Escape] - } -escapeUpLit = escapeUpDark - { tfreq = [("litLegend", 100)] - , tfeature = Lit : tfeature escapeUpDark - } -escapeDownDark = TileKind - { tsymbol = '>' - , tname = "exit trapdoor down" - , tfreq = [("darkLegend", 100)] - , tcolor = BrYellow - , tcolor2 = BrYellow - , tfeature = [Walkable, Clear, Exit, Cause Effect.Escape] - } -escapeDownLit = escapeDownDark - { tfreq = [("litLegend", 100)] - , tfeature = Lit : tfeature escapeDownDark - } -unknown = TileKind - { tsymbol = ' ' - , tname = "unknown space" - , tfreq = [("unknown space", 1)] - , tcolor = defFG - , tcolor2 = BrWhite - , tfeature = [] - } -floorCorridorLit = TileKind - { tsymbol = '#' - , tname = "corridor" - , tfreq = [("floorCorridorLit", 1)] - , tcolor = BrWhite - , tcolor2 = defFG - , tfeature = [Walkable, Clear, Lit] - } -floorCorridorDark = floorCorridorLit - { tfreq = [("floorCorridorDark", 1)] --- Disabled, because dark corridors and yellow light does not fit LambdaHack. --- , tcolor = BrYellow --- , tcolor2 = BrBlack - , tfeature = [Walkable, Clear] - } -floorArenaLit = floorCorridorLit - { tsymbol = '.' - , tname = "stone floor" - , tfreq = [ ("floorArenaLit", 1) - , ("arenaSet", 1), ("noiseSet", 100), ("combatSet", 100) ] - } -floorArenaDark = floorCorridorDark - { tsymbol = '.' - , tname = "stone floor" - , tfreq = [("arenaSet", 1), ("noiseSet", 100), ("combatSet", 100)] --- Disabled, because the yellow artificial light does not fit LambdaHack. --- , tcolor = BrYellow --- Dark room interior, OTOH, is fine: - , tcolor2 = BrBlack - } -floorItemLit = floorArenaLit - { tfreq = [] - , tfeature = CanItem : tfeature floorArenaLit - } -floorItemDark = floorArenaDark - { tfreq = [] - , tfeature = CanItem : tfeature floorArenaDark - } -floorActorItemLit = floorItemLit - { tfreq = [("litLegend", 100), ("emptySet", 1)] - , tfeature = CanActor : tfeature floorItemLit - } -floorActorItemDark = floorItemDark - { tfreq = [("darkLegend", 100), ("emptySet", 1)] - , tfeature = CanActor : tfeature floorItemDark - } -floorRedDark = floorArenaDark - { tname = "brick pavement" - , tfreq = [("pathDark", 30)] - , tcolor = BrRed - , tcolor2 = Red - , tfeature = Path : tfeature floorArenaDark - } -floorRedLit = floorRedDark - { tfreq = [("pathLit", 30)] - , tfeature = Lit : tfeature floorRedDark - } -floorBlueDark = floorRedDark - { tname = "granite cobblestones" - , tfreq = [("pathDark", 100)] - , tcolor = BrBlue - , tcolor2 = Blue - } -floorBlueLit = floorBlueDark - { tfreq = [("pathLit", 100)] - , tfeature = Lit : tfeature floorBlueDark - } -floorGreenDark = floorRedDark - { tname = "mossy stone path" - , tfreq = [("pathDark", 100)] - , tcolor = BrGreen - , tcolor2 = Green - } -floorGreenLit = floorGreenDark - { tfreq = [("pathLit", 100)] - , tfeature = Lit : tfeature floorGreenDark - } -floorBrownDark = floorRedDark - { tname = "rotting mahogany deck" - , tfreq = [("pathDark", 10)] - , tcolor = BrMagenta - , tcolor2 = Magenta - } -floorBrownLit = floorBrownDark - { tfreq = [("pathLit", 10)] - , tfeature = Lit : tfeature floorBrownDark - } diff --git a/LambdaHack/Main.hs b/LambdaHack/Main.hs deleted file mode 100644 --- a/LambdaHack/Main.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | The main source code file of LambdaHack. Here the knot of engine --- code pieces and the LambdaHack-specific content defintions is tied, --- resulting in an executable game. -module Main ( main ) where - -import qualified Content.ActorKind -import qualified Content.CaveKind -import qualified Content.FactionKind -import qualified Content.ItemKind -import qualified Content.ModeKind -import qualified Content.PlaceKind -import qualified Content.RuleKind -import qualified Content.TileKind -import Game.LambdaHack.Client -import Game.LambdaHack.Client.Action.ActionType -import Game.LambdaHack.Common.Action (MonadAtomic (..)) -import Game.LambdaHack.Common.AtomicCmd -import Game.LambdaHack.Common.AtomicSem -import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Server -import Game.LambdaHack.Server.Action.ActionType -import Game.LambdaHack.Server.AtomicSemSer - --- | The game-state semantics of atomic game commands --- as computed on the server. -instance MonadAtomic ActionSer where - execAtomic = atomicSendSem - --- | The game-state semantics of atomic game commands --- as computed on clients. Special effects (@SfxAtomic@) don't modify state. -instance MonadAtomic (ActionCli c d) where - execAtomic (CmdAtomic cmd) = cmdAtomicSem cmd - execAtomic (SfxAtomic _) = return () - --- | Tie the LambdaHack engine clients and server code --- with the LambdaHack-specific content defintions and run the game. -main :: IO () -main = - let copsSlow = Kind.COps - { coactor = Kind.createOps Content.ActorKind.cdefs - , cocave = Kind.createOps Content.CaveKind.cdefs - , cofaction = Kind.createOps Content.FactionKind.cdefs - , coitem = Kind.createOps Content.ItemKind.cdefs - , comode = Kind.createOps Content.ModeKind.cdefs - , coplace = Kind.createOps Content.PlaceKind.cdefs - , corule = Kind.createOps Content.RuleKind.cdefs - , cotile = Kind.createOps Content.TileKind.cdefs - } - in mainSer copsSlow executorSer $ exeFrontend executorCli executorCli diff --git a/MainMenu.ascii b/MainMenu.ascii deleted file mode 100644 --- a/MainMenu.ascii +++ /dev/null @@ -1,26 +0,0 @@ ----------------------------------------------------------------------------------- -| | -| >> LambdaHack << | -| | -| | -| | -| {{{{{{{{{{{{{{{{{{{{{{{{{ | -| | -| {{{{{{{{{{{{{{{{{{{{{{{{{ | -| | -| {{{{{{{{{{{{{{{{{{{{{{{{{ | -| | -| {{{{{{{{{{{{{{{{{{{{{{{{{ | -| | -| {{{{{{{{{{{{{{{{{{{{{{{{{ | -| | -| {{{{{{{{{{{{{{{{{{{{{{{{{ | -| | -| {{{{{{{{{{{{{{{{{{{{{{{{{ | -| | -| {{{{{{{{{{{{{{{{{{{{{{{{{ | -| | -| | -| | -| Version X.X.X (frontend: gtk, engine: LambdaHack X.X.X) | ----------------------------------------------------------------------------------- diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -12,134 +12,228 @@ dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer xcpeekCampaign: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign xcpeekSkirmish: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish xcfrontendCampaign: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode screensaver + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testCampaign --difficulty 1 +xcfrontendSkirmish: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testSkirmish + +xcfrontendBattle: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testBattle --difficulty 1 + +xcfrontendPvP: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testPvP --fovMode Shadow + xcfrontendCoop: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --fovMode Permissive --savePrefix test --gameMode testCoop + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testCoop --difficulty 1 --fovMode Permissive xcfrontendDefense: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode testDefense + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testDefense --difficulty 9 +xcbenchCampaign: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendNo --benchmark --stopAfter 60 --gameMode testCampaign --difficulty 1 --setDungeonRng 42 --setMainRng 42 -xctest-travis: xctest-short xctest-medium +xcbenchBattle: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendNo --benchmark --stopAfter 60 --gameMode testBattle --difficulty 1 --setDungeonRng 42 --setMainRng 42 +xcbenchFrontendCampaign: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --benchmark --stopAfter 60 --gameMode testCampaign --difficulty 1 --setDungeonRng 42 --setMainRng 42 + +xcbenchFrontendBattle: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --benchmark --stopAfter 60 --gameMode testBattle --difficulty 1 --setDungeonRng 42 --setMainRng 42 + +xcbenchNo: xcbenchCampaign xcbenchBattle + +xcbench: xcbenchCampaign xcbenchFrontendCampaign xcbenchBattle xcbenchFrontendBattle + +xctest-travis: xctest-short xctest-medium xcbenchNo + +xctest-travis-long: xctest-short xctest-long xcbenchNo + xctest: xctest-short xctest-medium xctest-long xctest-short: xctest-short-new xctest-short-load -xctest-medium: xctestCampaign-medium xctestCoop-medium xctestDefense-medium +xctest-medium: xctestCampaign-medium xctestSkirmish-medium xctestBattle-medium xctestPvP-medium xctestCoop-medium xctestDefense-medium xctest-long: xctestCampaign-long xctestCoop-long xctestDefense-long xctestCampaign-long: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --stopAfter 1000 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testCampaign --difficulty 1 > /tmp/stdtest.log xctestCampaign-medium: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --dumpConfig --stopAfter 200 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testCampaign --difficulty 1 > /tmp/stdtest.log +xctestSkirmish-long: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testSkirmish > /tmp/stdtest.log + +xctestSkirmish-medium: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testSkirmish > /tmp/stdtest.log + +xctestBattle-long: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testBattle --difficulty 1 > /tmp/stdtest.log + +xctestBattle-medium: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testBattle --difficulty 1 > /tmp/stdtest.log + +xctestPvP-long: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testPvP > /tmp/stdtest.log + +xctestPvP-medium: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testPvP > /tmp/stdtest.log + xctestCoop-long: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --fovMode Permissive --savePrefix test --gameMode testCoop --frontendStd --stopAfter 1000 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testCoop --difficulty 1 > /tmp/stdtest.log xctestCoop-medium: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --fovMode Shadow --savePrefix test --gameMode testCoop --frontendStd --dumpConfig --stopAfter 200 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testCoop --difficulty 1 > /tmp/stdtest.log xctestDefense-long: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noAnim --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --stopAfter 1000 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testDefense --difficulty 9 > /tmp/stdtest.log xctestDefense-medium: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --dumpConfig --stopAfter 200 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testDefense --difficulty 9 > /tmp/stdtest.log xctest-short-new: - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix campaign --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix skirmish --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix PvP --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix Coop --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix defense --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix peekCampaign --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix peekSkirmish --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix campaign --dumpInitRngs --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix skirmish --dumpInitRngs --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix battle --dumpInitRngs --gameMode battle --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix PvP --dumpInitRngs --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix Coop --dumpInitRngs --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix defense --dumpInitRngs --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log xctest-short-load: - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix campaign --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix skirmish --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix PvP --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix Coop --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix defense --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix campaign --dumpInitRngs --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix skirmish --dumpInitRngs --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix battle --dumpInitRngs --gameMode battle --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix PvP --dumpInitRngs --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix Coop --dumpInitRngs --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix defense --dumpInitRngs --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log play: dist/build/LambdaHack/LambdaHack --dbgMsgSer peekCampaign: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign peekSkirmish: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish frontendCampaign: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode screensaver + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testCampaign --difficulty 1 +frontendSkirmish: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testSkirmish + +frontendBattle: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testBattle --difficulty 1 + +frontendPvP: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testPvP --fovMode Shadow + frontendCoop: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --fovMode Permissive --savePrefix test --gameMode testCoop + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testCoop --difficulty 1 --fovMode Permissive frontendDefense: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode testDefense + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testDefense --difficulty 9 +benchCampaign: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendNo --benchmark --stopAfter 60 --gameMode testCampaign --difficulty 1 --setDungeonRng 42 --setMainRng 42 -test-travis: test-short test-medium +benchBattle: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendNo --benchmark --stopAfter 60 --gameMode testBattle --difficulty 1 --setDungeonRng 42 --setMainRng 42 +benchFrontendCampaign: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --benchmark --stopAfter 60 --gameMode testCampaign --difficulty 1 --setDungeonRng 42 --setMainRng 42 + +benchFrontendBattle: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --benchmark --stopAfter 60 --gameMode testBattle --difficulty 1 --setDungeonRng 42 --setMainRng 42 + +benchNo: benchCampaign benchBattle + +bench: benchCampaign benchFrontendCampaign benchBattle benchFrontendBattle + + +test-travis: test-short test-medium benchNo + +test-travis-long: test-short test-long benchNo + test: test-short test-medium test-long test-short: test-short-new test-short-load -test-medium: testCampaign-medium testCoop-medium testDefense-medium +test-medium: testCampaign-medium testSkirmish-medium testBattle-medium testPvP-medium testCoop-medium testDefense-medium test-long: testCampaign-long testCoop-long testDefense-long testCampaign-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --stopAfter 1000 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testCampaign --difficulty 1 > /tmp/stdtest.log testCampaign-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --dumpConfig --stopAfter 200 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testCampaign --difficulty 1 > /tmp/stdtest.log +testSkirmish-long: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testSkirmish > /tmp/stdtest.log + +testSkirmish-medium: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testSkirmish > /tmp/stdtest.log + +testBattle-long: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testBattle --difficulty 1 > /tmp/stdtest.log + +testBattle-medium: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testBattle --difficulty 1 > /tmp/stdtest.log + +testPvP-long: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testPvP > /tmp/stdtest.log + +testPvP-medium: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testPvP > /tmp/stdtest.log + testCoop-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --fovMode Permissive --savePrefix test --gameMode testCoop --frontendStd --stopAfter 1000 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testCoop --difficulty 1 > /tmp/stdtest.log testCoop-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --fovMode Shadow --savePrefix test --gameMode testCoop --frontendStd --dumpConfig --stopAfter 200 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testCoop --difficulty 1 > /tmp/stdtest.log testDefense-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noAnim --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --stopAfter 1000 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testDefense --difficulty 9 > /tmp/stdtest.log testDefense-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --dumpConfig --stopAfter 200 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testDefense --difficulty 9 > /tmp/stdtest.log test-short-new: - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix campaign --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix skirmish --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix PvP --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix Coop --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix defense --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekCampaign --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekSkirmish --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix campaign --dumpInitRngs --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix skirmish --dumpInitRngs --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix battle --dumpInitRngs --gameMode battle --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix PvP --dumpInitRngs --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix Coop --dumpInitRngs --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix defense --dumpInitRngs --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log test-short-load: - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix campaign --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix skirmish --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix PvP --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix Coop --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix defense --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log - while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix campaign --dumpInitRngs --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix skirmish --dumpInitRngs --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix battle --dumpInitRngs --gameMode battle --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix PvP --dumpInitRngs --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix Coop --dumpInitRngs --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix defense --dumpInitRngs --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log + while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log + # The rest of the makefile is unmaintained at the moment. default : dist/setup-config @@ -161,4 +255,4 @@ runghc Setup clean ghci : - ghci -XCPP -idist/build/autogen:Game/LambdaHack + ghci -XCPP -idist/build/autogen:. diff --git a/PLAYING.md b/PLAYING.md deleted file mode 100644 --- a/PLAYING.md +++ /dev/null @@ -1,171 +0,0 @@ -Playing LambdaHack -================== - -LambdaHack is a small dungeon crawler illustrating the roguelike game engine -library also called LambdaHack. Playing the game involves walking around -the dungeon, alone or in a party of fearless adventurers, setting up ambushes, -hiding in shadow, covering tracks, breaking through to deeper caves, -bumping into monsters, doors and walls, gathering magical treasure -and making creative use of it. The bloodthirsty monsters do the same, -intelligence allowing, while tirelessly chasing the elusive heroes -by smell and sight. - -Once the few basic command keys and on-screen symbols are learned, -mastery and enjoyment of the game is the matter of tactical skill -and literary imagination. To be honest, a lot of imagination is required -for this simple game, but it's playable and winnable. -The game also features multiplayer cooperative and competitive modes, -though only a shared-screen interface is provided at this time. - - -Dungeon -------- - -The heroes are marked on the map with symbols '@' and '1' through '9'. -Their goal is to explore the dungeon, battle the horrors within, -gather as much gold and gems as possible, and escape to tell the tale. -The dungeon of the campaign mode game consists of 10 levels and each level -consists of large number of tiles. The basic tiles are as follows. - - dungeon terrain type on-screen symbol - floor . - corridor # - wall (horizontal and vertical) - and | - rock or tree O - cache & - stairs up < - stairs down > - open door | and - - closed door + - bedrock blank - -The game world is persistent, i.e., every time the player visits a level -during a single game, the level layout is the same. - - -Keys ----- - -You move throughout the level using the numerical keypad or -the vi text editor keys (also known as "Rogue-like keys"). - - 7 8 9 y k u - \|/ \|/ - 4-5-6 h-.-l - /|\ /|\ - 1 2 3 b j n - -SHIFT (or CTRL) and a movement key make the selected hero run in the indicated -direction, until anything of interest is spotted. The '5' and '.' keys take -a turn to brace for combat, which gives a chance to block blows -for the remainder of the turn. Melee, searching for secret doors -and opening closed doors can be done by bumping into a monster, -a wall and a door, respectively. - -Below are the default keys for major commands. Those of them that take -hero time are marked with a star. - - key command - < ascend a level* - > descend a level* - ? display help - I display inventory - c close a door* - d drop an object* - g get an object* - o open a door* - q quaff a potion* - r read a scroll* - t throw a dart* - z zap a wand* - -To make a ranged attack, you need to set your target first, -using targeting mode ('*' and '/' keys). The target, for the few -commands that require any, is indicated by the targeting cursor. -To avoid confusion, commands that take time are blocked when targeting -at a remote level (when the cursor is displayed on a different level -than the selected hero). The targeting commands and all the less used -commands are listed below. None of them takes hero time. - - key command - ESC cancel action or bring up the Main Menu - RET accept choice - TAB cycle among heroes on the level - SHIFT-TAB cycle among heroes in the dungeon - * target monster - + swerve targeting line - - unswerve targeting line - / target position - P display previous messages - S mark smell - T mark suspect terrain - V mark visible area - [ target next shallower level - ] target next deeper level - { target 10 levels shallower - } target 10 levels deeper - 0--9 select a hero anywhere in the dungeon - -Commands for saving and exiting the current game, starting a new game, etc., -are listed in the Main Menu, brough up by the ESC key. -Some of the game modes are multiplayer or feature multiple computer -players (allied or not). The setup of the modes can be modified -via a configuration file. - - key command - CTRL-x save and exit - CTRL-r new campaign game - CTRL-k new skirmish game - CTRL-p new PvP game - CTRL-o new Coop game - CTRL-e new defense game - -There are also some debug, testing and cheat options and game modes -that can be specified on the command line when starting the game server. -Use at your own peril! :) Of these, you may find the screensaver modes -the least spoilery and the most fun, e.g.: - - LambdaHack --newGame --noMore --maxFps 45 --savePrefix screensaver --gameMode screensaver - - -Monsters --------- - -Heroes are not alone in the dungeon. Monsters roam the dark caves -and crawl from damp holes day and night. While heroes pay attention -to all other party members and take care to move one at a time, -monsters don't care about each other and all move at once, -sometimes brutally colliding by accident. - -When the hero bumps into a monster or a monster attacks the hero, -melee combat occurs. The best weapon carried by each opponent -is taken into account for calculating bonus damage. The total damage -the current hero can potentially inflict is displayed at the bottom -of the screen. The total damage potential of a monster may change -as it finds and picks up new weapons. Heroes and monsters running into -one another (with the Shift key) do not inflict damage, but change places. -This gives the opponent a free blow, but can improve the tactical situation -or aid escape. - -Throwing weapons at targets wounds them, consuming the weapon in the process. -Target a monster with the '*' key from the top keyboard row or from keypad. -You may throw any object in your possession (press '?' to choose -an object and press it again for a non-standard choice) or on the floor -(press '-'). Only objects of a few kinds inflict any damage. -Whenever the monster's or hero's hit points reach zero, the combatant dies. -When the last hero dies, the game ends. - - -On Winning and Dying --------------------- - -You win the game if you escape the dungeon alive (or eliminate -all opposition, in some game modes). Your score is -the sum of all gold you've plundered plus 100 gold pieces for each gem. -Only the loot in possession of the party members on the current level -counts (the rest of the party is considered MIA). - -If all heroes die, your score is halved and only the treasure carried -by the last standing hero counts. You are free to start again -from a different entrance to the dungeon, but all your previous wealth -is gone and fresh, undaunted enemies bar your way. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -LambdaHack [![Build Status](https://secure.travis-ci.org/kosmikus/LambdaHack.png)](http://travis-ci.org/kosmikus/LambdaHack) +LambdaHack [![Build Status](https://secure.travis-ci.org/kosmikus/LambdaHack.png)](http://travis-ci.org/kosmikus/LambdaHack)[![Build Status](https://drone.io/github.com/kosmikus/LambdaHack/status.png)](https://drone.io/github.com/kosmikus/LambdaHack/latest) ========== This is an alpha release of LambdaHack, a [Haskell] [1] game engine @@ -13,11 +13,10 @@ in the strict and type-safe separation of code and content and of clients (human and AI-controlled) and server. Long-term goals for LambdaHack include support for multiplayer tactical squad combat, in-game content creation, -auto-balancing and persistent content modification based -on player behaviour. +auto-balancing and persistent content modification based on player behaviour. The engine comes with a sample code for a little dungeon crawler, -called LambdaHack and described in PLAYING.md. The engine and the example +called LambdaHack and described in `PLAYING.md`. The engine and the example game are bundled together in a single [Hackage] [3] package. You are welcome to create your own games by modifying the sample game and the engine code, but please consider eventually splitting your changes @@ -32,9 +31,11 @@ Compilation and installation ---------------------------- -The library is best compiled and installed via Cabal, which also takes care -of all dependencies. The latest official version of the library -can be downloaded automatically by Cabal from [Hackage] [3] as follows +The library is best compiled and installed via Cabal (already a part +of your OS distribution, or available within [The Haskell Platform] [7]), +which also takes care of all the dependencies. The latest official +version of the library can be downloaded automatically by Cabal +from [Hackage] [3] as follows cabal install LambdaHack @@ -53,33 +54,31 @@ Compatibility notes ------------------- -The current code was tested with GHC 7.6.3, but should also work with -other GHC versions (see file .travis.yml.7.4.2 for GHC 7.4.2 commands). +The current code was tested with GHC 7.6 and 7.8, but should also work with +other GHC versions (see file `.travis.yml.7.4.2` for GHC 7.4 commands). -If you are using the curses or vty frontends, -numerical keypad may not work correctly depending on the versions -of curses, terminfo and terminal emulators. -Selecting heroes via number keys or SHIFT-keypad keys is disabled -with curses, because CTRL-keypad for running does not work there, -so the numbers produced by the keypad have to be used. With vty on xterm, -CTRL-direction keys seem to work OK, but on rxvt they do not. -Vi keys (ykuhlbjn) should work everywhere regardless. Gtk works fine, too. +If you are using the terminal frontends, numerical keypad may not work +correctly depending on versions of the libraries, terminfo and terminal +emulators. The curses frontend is not fully supported due to the limitations +of the curses library. With the vty frontend run in an xterm, +CTRL-keypad keys for running seem to work OK, but on rxvt they do not. +Vi keys (ykuhlbjn) should work everywhere regardless. GTK works fine, too. Testing and debugging --------------------- -The Makefile contains many sample test commands. All that use the screensaver +The `Makefile` contains many sample test commands. All that use the screensaver game modes (AI vs. AI) and the simplest stdout frontend are gathered -in `make test`. Of these, travis runs the set contained in -`make test-travis` on each push to the repo. Commands with prefix +in `make test`. Of these, travis runs one of the sets prefixed +`test-travis` on each push to the repo. Commands with prefix `frontend` run AI vs. AI games with the standard, user-friendly frontend. Commands with prefix `peek` set up a game mode where the player peeks into AI moves each time an AI actor dies or autosave kicks in. Run `LambdaHack --help` to see a brief description of all debug options. Of these, `--sniffIn` and `--sniffOut` are very useful (though verbose and initially cryptic), for monitoring the traffic between clients -and the server. Some options in config files may turn out useful too, +and the server. Some options in the config file may turn out useful too, though they mostly overlap with commandline options (and will be totally merged at some point). @@ -101,7 +100,7 @@ ------------------- For more information, visit the [wiki] [4] -and see the files PLAYING.md, CREDITS and LICENSE. +and see `GameDefinition/PLAYING.md`, `CREDITS` and `LICENSE`. Have fun! @@ -113,3 +112,4 @@ [4]: https://github.com/kosmikus/LambdaHack/wiki [5]: http://github.com/kosmikus/LambdaHack [6]: http://hackage.haskell.org/package/Allure +[7]: http://www.haskell.org/platform diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,44 +1,55 @@ -0.2.0 - - * the LambdaHack engine becomes a Haskell library - - * the LambdaHack game depends on the engine library - -0.2.1 - - * missiles flying for three turns (by an old kosmikus' idea) - - * visual feedback for targeting - - * animations of combat and individual monster moves - -0.2.6 - - * the Main Menu +v0.2.12 - * improved and configurable mode of squad combat + * improve and simplify dungeon generation + * simplify running and permit multi-actor runs + * let items explode and generate shrapnel projectiles + * add game difficulty setting (initial HP scaling right now) + * allow recording, playing back and looping commands + * implement pathfinding via per-actor BFS over the whole level + * extend setting targets for actors in UI tremendously + * implement autoexplore, go-to-target, etc., as macros + * let AI use pathfinding, switch leaders, pick levels to swarm to + * force level/leader changes on spawners (even when played by humans) + * extend and redesign UI bottom status lines + * get rid of CPS style monads, aborts and WriterT + * benchmark and optimize the code, in particular using Data.Vector + * split off and use the external library assert-failure + * simplify config files and limit the number of external dependencies -0.2.6.5 +v0.2.10 - * this is a minor release, primarily intended to fix the broken haddock documentation on Hackage + * screensaver game modes (AI vs AI) + * improved AI (can now climbs stairs, etc.) + * multiple, multi-floor staircases + * multiple savefiles + * configurable framerate and combat animations - * changes since 0.2.6 are mostly unrelated to gameplay: strictly typed config files split into UI and rules; a switch from Text to String throughout the codebase; use of the external library miniutter for English sentence generation +v0.2.8 -0.2.8 + * cooperative and competitive multiplayer (shared-screen only in this version) + * overhauled searching + * rewritten engine code to have a single server that sends restricted game state updates to many fat clients, while a thin frontend layer multiplexes visuals from a subset of the clients - * cooperative and competitive multiplayer (shared-screen only in this version) - * overhauled searching +v0.2.6.5 - * rewritten engine code to have a single server that sends restricted game state updates to many fat clients, while a thin frontend layer multiplexes visuals from a subset of the clients + * this is a minor release, primarily intended to fix the broken haddock documentation on Hackage + * changes since 0.2.6 are mostly unrelated to gameplay: + - strictly typed config files split into UI and rules + - a switch from Text to String throughout the codebase + - use of the external library miniutter for English sentence generation -0.2.10 +v0.2.6 - * screensaver game modes (AI vs AI) + * the Main Menu + * improved and configurable mode of squad combat - * improved AI (can now climbs stairs, etc.) +v0.2.1 - * multiple, multi-floor staircases + * missiles flying for three turns (by an old kosmikus' idea) + * visual feedback for targeting + * animations of combat and individual monster moves - * multiple savefiles +v0.2.0 - * configurable framerate and combat animations + * the LambdaHack engine becomes a Haskell library + * the LambdaHack game depends on the engine library diff --git a/config.rules.default b/config.rules.default deleted file mode 100644 --- a/config.rules.default +++ /dev/null @@ -1,28 +0,0 @@ -; ; This is a commented out copy of the default game rules config file -; ; that is embedded in the binary. -; ; A user config file can overrides these options. The game looks for it at -; ; ~/.LambdaHack/config.rules.ini (or a similar path, depending on the OS). -; ; Warning: options are case-sensitive and only ';' for comments is permitted. - -; [engine] -; ;dungeonRandomGenerator: 42 -; firstDeathEnds: False -; fovMode: Digital 12 -; ;fovMode: Permissive -; ;fovMode: Shadow -; ;startingRandomGenerator: 42 -; saveBkpClips: 500 - -; [file] -; ; Names (or prefixes) of various game files. -; ; They reside in ~/.LambdaHack or similar. -; savePrefix: save -; scoresFile: scores - -; [heroName] -; HeroName_0: Haskell Alvin -; HeroName_1: Alonzo Barkley -; HeroName_2: Ines Galenti -; HeroName_3: Ernst Abraham -; HeroName_4: Samuel Saunders -; HeroName_5: Roger Robin diff --git a/config.ui.default b/config.ui.default deleted file mode 100644 --- a/config.ui.default +++ /dev/null @@ -1,63 +0,0 @@ -; ; This is a commented out copy of the default UI settings config file -; ; that is embedded in the binary. -; ; A user config file can overrides these options. The game looks for it at -; ; ~/.LambdaHack/config.ui.ini (or a similar path, depending on the OS). -; ; Warning: options are case-sensitive and only ';' for comments is permitted. - -; [commands] -; ; All commands are defined here, except movement, hero selection and debug. -; ; -; KP_Begin: Wait -; g: Pickup -; d: Drop -; t: Project [ApplyItem {verb = "throw", object = "missile", symbol = '|'}] -; z: Project [ApplyItem {verb = "zap", object = "wand", symbol = '/'}] -; q: Apply [ApplyItem {verb = "quaff", object = "potion", symbol = '!'}] -; r: Apply [ApplyItem {verb = "read", object = "scroll", symbol = '?'}] -; c: AlterDir [AlterFeature {verb = "close", object = "door", feature = CloseTo "vertical closed door"}, AlterFeature {verb = "close", object = "door", feature = CloseTo "horizontal closed door"}] -; o: AlterDir [AlterFeature {verb = "open", object = "door", feature = OpenTo "vertical open door"}, AlterFeature {verb = "open", object = "door", feature = OpenTo "horizontal open door"}] -; less: TriggerTile [TriggerFeature {verb = "ascend", object = "level", feature = Cause (Ascend 1)}, TriggerFeature {verb = "escape", object = "dungeon", feature = Cause Escape}] -; greater: TriggerTile [TriggerFeature {verb = "descend", object = "level", feature = Cause (Ascend (-1))}, TriggerFeature {verb = "escape", object = "dungeon", feature = Cause Escape}] -; CTRL-r: GameRestart "campaign" -; ; TODO: pick game modes via arrow keys, not special keys -; CTRL-k: GameRestart "skirmish" -; CTRL-p: GameRestart "PvP" -; CTRL-o: GameRestart "Coop" -; CTRL-e: GameRestart "defense" -; CTRL-x: GameExit -; CTRL-s: GameSave -; Tab: MemberCycle -; ISO_Left_Tab: MemberBack -; I: Inventory -; slash: TgtFloor -; asterisk: TgtEnemy -; bracketleft: TgtAscend 1 -; bracketright: TgtAscend (-1) -; braceleft: TgtAscend 10 -; braceright: TgtAscend (-10) -; plus: EpsIncr True -; minus: EpsIncr False -; Escape: Cancel -; Return: Accept -; space: Clear -; P: History -; V: MarkVision -; S: MarkSmell -; T: MarkSuspect -; question: Help - -; [file] -; ; Names (or prefixes) of various game files. -; ; They reside in ~/.LambdaHack or similar. -; savePrefix: save - -; [macros] -; ; Handy with Vi keys: -; comma: g -; period: KP_Begin - -; [ui] -; font: Terminus,Monospace normal normal normal normal 12 -; historyMax: 5000 -; maxFps: 15 -; noAnim: False diff --git a/scores b/scores deleted file mode 100644 Binary files a/scores and /dev/null differ