diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -2,6 +2,8 @@ install: - cabal install gtk2hs-buildtools - - cabal install ConfigFile regex-posix regex-compat gtk --enable-tests --reinstall --force-reinstalls --constraint="mtl>=2.1.2" --constraint="containers>=0.5.2.1" --constraint="template-haskell==2.7.0.0" --constraint="text>=0.11.2.3" - - cabal install --enable-tests --force-reinstalls --constraint="mtl>=2.1.2" --constraint="containers>=0.5.2.1" --constraint="template-haskell==2.7.0.0" --constraint="text>=0.11.2.3" - - make test-travis + - cabal install --only-dependencies + +script: + - cabal install + - 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 @@ -28,7 +28,7 @@ import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State import Game.LambdaHack.Frontend -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar storeUndo :: MonadClient m => Atomic -> m () storeUndo _atomic = @@ -64,7 +64,7 @@ storeUndo $ SfxAtomic sfx CmdQueryUI aid -> do mleader <- getsClient _sleader - assert (isJust mleader `blame` "query without leader" `with` cmd) skip + assert (isJust mleader `blame` "query without leader" `twith` cmd) skip cmdH <- queryUI aid writeServer cmdH CmdPingUI -> do @@ -119,7 +119,7 @@ s = updateCOps (const cops) emptyState eClientAI fid = let noSession = assert `failure` "AI client needs no UI session" - `with` fid + `twith` fid in exeClientAI noSession s (cli fid True) eClientUI fid fromF = let sfconn = connFrontend fid fromF 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 @@ -36,6 +36,8 @@ 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) @@ -51,15 +53,16 @@ import System.Time import Game.LambdaHack.Client.Action.ActionClass -import Game.LambdaHack.Client.Action.ConfigIO 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.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 Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.HighScore as HighScore import qualified Game.LambdaHack.Common.Key as K @@ -74,7 +77,6 @@ import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Frontend as Frontend -import Game.LambdaHack.Utils.Assert debugPrint :: MonadClient m => Text -> m () debugPrint t = do @@ -115,7 +117,7 @@ tryIgnore = tryWith (\msg -> unless (T.null msg) $ assert `failure` "can't catch failure with message" - `with` msg) + `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). @@ -165,7 +167,7 @@ getLeaderUI = do cli <- getClient case _sleader cli of - Nothing -> assert `failure` "leader expected but not found" `with` cli + Nothing -> assert `failure` "leader expected but not found" `twith` cli Just leader -> return leader getArenaUI :: MonadClientUI m => m LevelId @@ -184,7 +186,7 @@ let (minD, maxD) = case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) - _ -> assert `failure` "empty dungeon" `with` dungeon + _ -> assert `failure` "empty dungeon" `twith` dungeon return $ max minD $ min maxD $ playerEntry $ gplayer fact -- | Calculate the position of leader's target. @@ -234,7 +236,7 @@ getPerFid lid = do fper <- getsClient sfper return $! fromMaybe (assert `failure` "no perception at given level" - `with` (lid, fper)) + `twith` (lid, fper)) $ EM.lookup lid fper -- | Display an overlay and wait for a human player command. @@ -331,6 +333,9 @@ per <- getPerFid lid return $! draw dm cops per lid mleader cli s 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 +-- each time screen is refreshed. -- | Push the frame depicting the current level to the frame queue. -- Only one screenful of the report is shown, the rest is ignored. displayPush :: MonadClientUI m => m () @@ -384,7 +389,6 @@ modifyClient $ \cli -> cli {srandom = ng} return a --- TODO: perhaps draw viewed level, not arena -- TODO: restrict the animation to 'per' before drawing. -- | Render animations on top of the current screen frame. animate :: MonadClientUI m => LevelId -> Animation -> m Frames @@ -420,3 +424,44 @@ partAidLeader aid = do 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" + 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" + 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, + return $! deepseq conf conf 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 @@ -7,7 +7,9 @@ ( FunActionCli, ActionCli, executorCli ) where +import Control.Applicative import Control.Concurrent.STM +import Control.Monad import qualified Data.EnumMap.Strict as EM import Data.Maybe import qualified Data.Text as T @@ -54,6 +56,10 @@ 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 diff --git a/Game/LambdaHack/Client/Action/ConfigIO.hs b/Game/LambdaHack/Client/Action/ConfigIO.hs deleted file mode 100644 --- a/Game/LambdaHack/Client/Action/ConfigIO.hs +++ /dev/null @@ -1,120 +0,0 @@ --- | Personal game configuration file support. -module Game.LambdaHack.Client.Action.ConfigIO - ( mkConfigUI - ) where - -import Control.DeepSeq -import qualified Data.Char as Char -import qualified Data.ConfigFile as CF -import System.Directory -import System.Environment -import System.FilePath - -import Game.LambdaHack.Client.Config -import Game.LambdaHack.Client.HumanCmd -import qualified Game.LambdaHack.Common.Key as K -import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Utils.Assert - --- TODO: Refactor the client and server ConfigIO.hs, after --- https://github.com/kosmikus/LambdaHack/issues/45. - -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 $ 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 = 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 - --- | 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} - --- | 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 forceEither $ CF.get conf s o - else assert `failure` "unknown CF option" `with` (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 forceEither $ CF.items conf s - else assert `failure` "unknown CF section" `with` (s, CF.to_string conf) - -parseConfigUI :: FilePath -> CP -> ConfigUI -parseConfigUI dataDir cp = - let mkKey s = - case K.keyTranslate s of - K.Unknown _ -> - assert `failure` "unknown config file key" `with` (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 = getItems cp "commands" - in map mkCommand section - configAppDataDir = dataDir - configUICfgFile = dataDir "config.ui" - configSavePrefix = 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" `with` toTr - else (fromTr, toTr) - section = getItems cp "macros" - in map trMacro section - configFont = get cp "ui" "font" - configHistoryMax = get cp "ui" "historyMax" - configMaxFps = get cp "ui" "maxFps" - configNoAnim = get cp "ui" "noAnim" - in ConfigUI{..} - --- | Read and parse UI config file. -mkConfigUI :: Kind.Ops RuleKind -> IO ConfigUI -mkConfigUI corule = do - let cpUIDefault = rcfgUIDefault $ Kind.stdRuleset corule - appData <- appDataDir - cpUI <- mkConfig cpUIDefault $ appData "config.ui.ini" - let conf = parseConfigUI appData cpUI - -- Catch syntax errors ASAP, - return $! deepseq conf conf 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 @@ -37,7 +37,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.TileKind -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar -- * CmdAtomicAI @@ -82,7 +82,7 @@ ] else -- Misguided. assert `failure` "LoseTile fails to reset memory" - `with` (aid, p, fromTile, toTile, b, t, cmd) + `twith` (aid, p, fromTile, toTile, b, t, cmd) DiscoverA _ _ iid _ -> do disco <- getsClient sdisco item <- getsState $ getItemBody iid @@ -164,7 +164,7 @@ mleader <- getsClient _sleader assert (mleader == source -- somebody changed the leader for us || mleader == target -- we changed the leader originally - `blame` "unexpected leader" `with` (cmd, mleader)) skip + `blame` "unexpected leader" `twith` (cmd, mleader)) skip 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 @@ -226,7 +226,7 @@ , psmell = PerceptionVisible ES.empty } outPer = paToDummy outPA inPer = paToDummy inPA - adj Nothing = assert `failure` "no perception to alter" `with` lid + adj Nothing = assert `failure` "no perception to alter" `twith` lid adj (Just per) = Just $ dummyToPer $ addPer (diffPer per outPer) inPer f = EM.alter adj lid modifyClient $ \cli -> cli {sfper = f (sfper cli)} @@ -237,16 +237,16 @@ item <- getsState $ getItemBody iid let f Nothing = Just ik f (Just ik2) = assert `failure` "already discovered" - `with` (lid, p, iid, ik, ik2) + `twith` (lid, p, iid, ik, ik2) modifyClient $ \cli -> cli {sdisco = EM.alter f (jkindIx item) (sdisco cli)} coverA :: MonadClient m => LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m () coverA lid p iid ik = do item <- getsState $ getItemBody iid - let f Nothing = assert `failure` "already covered" `with` (lid, p, iid, ik) + let f Nothing = assert `failure` "already covered" `twith` (lid, p, iid, ik) f (Just ik2) = assert (ik == ik2 `blame` "unexpected covered item kind" - `with` (ik, ik2)) Nothing + `twith` (ik, ik2)) Nothing modifyClient $ \cli -> cli {sdisco = EM.alter f (jkindIx item) (sdisco cli)} killExitA :: MonadClient m => m () 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 @@ -2,7 +2,7 @@ module Game.LambdaHack.Client.ClientSem where import Control.Monad -import Control.Monad.Writer.Strict (WriterT, runWriterT) +import Control.Monad.Writer.Strict (runWriterT) import qualified Data.EnumMap.Strict as EM import qualified Data.Map.Strict as M import Data.Maybe @@ -36,12 +36,12 @@ import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency queryAI :: MonadClient m => ActorId -> m CmdSerTakeTime queryAI oldAid = do - Kind.COps{cofact=Kind.Ops{okind}, corule} <- getsState scops + 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 @@ -131,11 +131,11 @@ queryAIPick :: MonadClient m => ActorId -> m CmdSerTakeTime queryAIPick aid = do - Kind.COps{cofact=Kind.Ops{okind}} <- getsState scops + Kind.COps{cofaction=Kind.Ops{okind}} <- getsState scops side <- getsClient sside body <- getsState $ getActorBody aid assert (bfid body == side `blame` "AI tries to move enemy actor" - `with` (aid, bfid body, side)) skip + `twith` (aid, bfid body, side)) skip mleader <- getsClient _sleader fact <- getsState $ (EM.! bfid body) . sfactionD let factionAbilities @@ -170,7 +170,7 @@ -- the human player issue commands, until any of them takes time. leader <- getLeaderUI assert (leader == aid `blame` "player moves not his leader" - `with` (leader, aid)) skip + `twith` (leader, aid)) skip let inputHumanCmd msg = do stopRunning humanCommand msg @@ -223,7 +223,7 @@ Just cmdS -> do assert (null (runSlideshow slides) `blame` "some slides generated for server command" - `with` slides) skip + `twith` slides) skip -- Exit the loop and let other actors act. No next key needed -- and no slides could have been generated. modifyClient (\st -> st {slastKey = Nothing}) diff --git a/Game/LambdaHack/Client/HumanCmd.hs b/Game/LambdaHack/Client/HumanCmd.hs --- a/Game/LambdaHack/Client/HumanCmd.hs +++ b/Game/LambdaHack/Client/HumanCmd.hs @@ -10,10 +10,10 @@ 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 -import Game.LambdaHack.Utils.Assert -- | Abstract syntax of player commands. data HumanCmd = @@ -31,7 +31,6 @@ | GameRestart !Text | GameExit | GameSave - | CfgDump -- These do not notify the server. | SelectHero !Int | MemberCycle @@ -77,7 +76,6 @@ -- | Minor commands land on the second page of command help. minorHumanCmd :: HumanCmd -> Bool minorHumanCmd cmd = case cmd of --- CfgDump -> True MemberCycle -> True MemberBack -> True TgtFloor -> True @@ -125,7 +123,6 @@ GameRestart t -> "new" <+> t <+> "game" GameExit -> "save and exit" GameSave -> "save game" - CfgDump -> "dump current configuration" SelectHero{} -> "select hero" MemberCycle -> "cycle among heroes on the level" @@ -138,7 +135,7 @@ 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" `with` cmd + assert `failure` "void level change when targeting" `twith` cmd EpsIncr True -> "swerve targeting line" EpsIncr False -> "unswerve targeting line" Cancel -> "cancel action" 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 @@ -4,7 +4,7 @@ module Game.LambdaHack.Client.HumanGlobal ( moveRunAid, displaceAid, meleeAid, waitHuman, pickupHuman, dropHuman , projectAid, applyHuman, alterDirHuman, triggerTileHuman - , gameRestartHuman, gameExitHuman, gameSaveHuman, cfgDumpHuman + , gameRestartHuman, gameExitHuman, gameSaveHuman ) where import Control.Monad @@ -16,6 +16,7 @@ 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.Draw import Game.LambdaHack.Client.HumanCmd (Trigger (..)) @@ -39,7 +40,6 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.TileKind as TileKind -import Game.LambdaHack.Utils.Assert abortFailure :: MonadClientAbort m => FailureSer -> m a abortFailure = abortWith . showFailureSer @@ -256,13 +256,13 @@ K.Char l -> case find ((InvChar l ==) . snd . snd) ims of Nothing -> assert `failure` "unexpected inventory letter" - `with` (km, l, ims) + `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:" `with` km + _ -> assert `failure` "unexpected key:" `twith` km ask -- * Project @@ -274,7 +274,7 @@ target <- targetToPos let tpos = case target of Just p -> p - Nothing -> assert `failure` "target unexpectedly invalid" `with` source + Nothing -> assert `failure` "target unexpectedly invalid" `twith` source eps <- getsClient seps sb <- getsState $ getActorBody source let lid = blid sb @@ -288,7 +288,7 @@ case bla lxsize lysize eps spos tpos of Nothing -> abortFailure ProjectAimOnself Just [] -> assert `failure` "project from the edge of level" - `with` (spos, tpos, sb, ts) + `twith` (spos, tpos, sb, ts) Just (pos : _) -> do as <- getsState $ actorList (const True) lid lvl <- getLevel lid @@ -512,10 +512,3 @@ -- TODO: do not save to history: msgAdd "Saving game backup." return $ GameSaveSer leader - --- * CfgDump; does not take time - -cfgDumpHuman :: MonadClientUI m => m CmdSer -cfgDumpHuman = do - leader <- getLeaderUI - return $ CfgDumpSer 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 @@ -32,6 +32,7 @@ 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 @@ -55,7 +56,6 @@ import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind -import Game.LambdaHack.Utils.Assert -- * Move and Run @@ -76,7 +76,7 @@ stgtMode <- getsClient stgtMode cli <- getClient let tgtId = maybe (assert `failure` "not targetting right now" - `with` cli) tgtLevelId stgtMode + `twith` cli) tgtLevelId stgtMode return $! dungeon EM.! tgtId viewedLevel :: MonadClientUI m => m (LevelId, Level) @@ -222,7 +222,7 @@ [] -> abortWith "Cannot select any other member on this level." (np, b) : _ -> do success <- selectLeader np - assert (success `blame` "same leader" `with` (leader, np, b)) skip + assert (success `blame` "same leader" `twith` (leader, np, b)) skip partyAfterLeader :: MonadActionRO m => ActorId @@ -249,7 +249,7 @@ else do pbody <- getsState $ getActorBody actor assert (not (bproj pbody) `blame` "projectile chosen as the leader" - `with` (actor, pbody)) skip + `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"] @@ -279,12 +279,13 @@ [] -> abortWith "No other member in the party." (np, b) : _ -> do success <- selectLeader np - assert (success `blame` "same leader" `with` (leader, np, b)) skip + assert (success `blame` "same leader" `twith` (leader, np, b)) skip -- * Inventory -- TODO: When inventory is displayed, let TAB switch the leader (without --- announcing that) and show the inventory of the new leader. +-- 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 () @@ -349,12 +350,11 @@ (lid, Level{lxsize}) <- viewedLevel per <- getPerFid lid target <- getsClient $ getTarget leader - -- TODO: sort enemies by distance to the leader. stgtMode <- getsClient stgtMode side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD bs <- getsState $ actorNotProjAssocs (isAtWar fact) lid - let ordPos (_, m) = (chessDist lxsize ppos $ bpos m, bpos m) + 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 @@ -365,8 +365,8 @@ in splitAt i dbs _ -> (dbs, []) -- target first enemy (e.g., number 0) gtlt = gt ++ lt - seen (_, m) = - let mpos = bpos m -- it is remembered by faction + 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 @@ -397,7 +397,7 @@ case rightStairs of Just cpos -> do -- stairs, in the right direction (nln, npos) <- getsState $ whereTo tgtId cpos k - assert (nln /= tgtId `blame` "stairs looped" `with` nln) skip + assert (nln /= tgtId `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) @@ -490,7 +490,7 @@ 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" `with` mainMenuArt + [] -> assert `failure` "empty Main Menu overlay" `twith` mainMenuArt hd : tl -> do slides <- overlayToSlideshow hd tl -- TODO: keys don't work if tl/=[] tell slides 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 @@ -7,6 +7,7 @@ import Control.Monad.Writer.Strict (WriterT) import Data.Maybe +import Control.Exception.Assert.Sugar import Game.LambdaHack.Client.Action import Game.LambdaHack.Client.HumanCmd import Game.LambdaHack.Client.HumanGlobal @@ -20,7 +21,6 @@ import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.Vector import Game.LambdaHack.Common.VectorXY -import Game.LambdaHack.Utils.Assert -- | The semantics of human player commands in terms of the @Action@ monad. -- Decides if the action takes time and what action to perform. @@ -51,7 +51,6 @@ GameRestart t -> fmap Just $ gameRestartHuman t GameExit -> fmap Just gameExitHuman GameSave -> fmap Just gameSaveHuman - CfgDump -> fmap Just cfgDumpHuman SelectHero k -> selectHeroHuman k >> return Nothing MemberCycle -> memberCycleHuman >> return Nothing @@ -113,7 +112,7 @@ 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" `with` (source, target, tb)) skip + assert (success `blame` "bump self" `twith` (source, target, tb)) skip return Nothing else -- Attacking does not require full access, adjacency is enough. 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 @@ -16,7 +16,7 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.State import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar initCli :: MonadClient m => DebugModeCli -> (State -> m ()) -> m Bool initCli sdebugCli putSt = do @@ -50,7 +50,7 @@ "Savefile of client" <+> showT side <+> "not usable. Removing server savefile. Please restart now." (False, CmdAtomicAI RestartA{}) -> return () - _ -> assert `failure` "unexpected command" `with` (side, restored, cmd1) + _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1) cmdClientAISem cmd1 -- State and client state now valid. debugPrint $ "AI client" <+> showT side <+> "started." @@ -90,7 +90,7 @@ let msg = "Welcome to" <+> title <> "!" cmdClientUISem cmd1 msgAdd msg - _ -> assert `failure` "unexpected command" `with` (side, restored, cmd1) + _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1) -- State and client state now valid. debugPrint $ "UI client" <+> showT side <+> "started." loop 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 @@ -9,6 +9,7 @@ import qualified Data.List as L import Data.Maybe +import Control.Exception.Assert.Sugar import Game.LambdaHack.Client.Action import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Action @@ -26,7 +27,6 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.TileKind -import Game.LambdaHack.Utils.Assert -- | Start running in the given direction and with the given number -- of tiles already traversed (usually 0). The first turn of running @@ -40,7 +40,7 @@ lvl <- getLevel $ blid b stgtMode <- getsClient stgtMode assert (isNothing stgtMode `blame` "attempt to run in target mode" - `with` (dir, dist, stgtMode)) skip + `twith` (dir, dist, stgtMode)) skip return $ accessibleDir cops lvl (bpos b) dir runDir :: MonadClient m => ActorId -> (Vector, Int) -> m (Vector, Int) @@ -74,7 +74,7 @@ in L.foldr f [] dirsEnterable = L.filter (dirEnterable pos) (moves lxsize) in case dirsEnterable of - [] -> assert `failure` "actor is stuck" `with` (pos, dir) -- TODO + [] -> assert `failure` "actor is stuck" `twith` (pos, dir) -- TODO [negdir] -> assert (negdir == neg dir) RunDeadEnd _ -> let dirsOpen = findOpen dirsEnterable @@ -116,12 +116,12 @@ ] -- Here additionally ignore a tile property if you stand on such tile. standList = [ posHasFeature F.Path - , not . posHasFeature F.Lit ] -- 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) 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 @@ -28,7 +28,7 @@ import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar -- | Client state, belonging to a single faction. -- Some of the data, e.g, the history, carries over @@ -125,7 +125,7 @@ let side1 = bfid $ getActorBody leader s side2 = sside cli in assert (side1 == side2 `blame` "enemy actor becomes our leader" - `with` (side1, side2, leader, s)) + `twith` (side1, side2, leader, s)) $ cli {_sleader = Just leader} sside :: StateClient -> FactionId 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 @@ -6,6 +6,7 @@ , (.|), reject, (.=>), only, bestVariant, renameStrategy, returN ) where +import Control.Applicative import Control.Monad import Data.Foldable (Foldable) import Data.Text (Text) @@ -31,12 +32,20 @@ | x <- runStrategy m , let name = "Strategy_bind (" <> nameFrequency x <> ")"] +instance Functor Strategy where + fmap f (Strategy fs) = Strategy (map (fmap f) fs) + +instance Applicative Strategy where + pure = return + (<*>) = ap + instance MonadPlus Strategy where mzero = Strategy [] mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys) -instance Functor Strategy where - fmap f (Strategy fs) = Strategy (map (fmap f) fs) +instance Alternative Strategy where + (<|>) = mplus + empty = mzero normalizeStrategy :: Strategy a -> Strategy a normalizeStrategy (Strategy fs) = Strategy $ filter (not . nullFreq) fs 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 @@ -36,7 +36,7 @@ import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind as TileKind -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency -- | AI proposes possible targets for the actor. Never empty. @@ -158,7 +158,7 @@ aFrequency Ability.Chase = if fpos == bpos then return mzero else chaseFreq aFrequency ab = assert `failure` "unexpected ability" - `with` (ab, distant, actorAbilities) + `twith` (ab, distant, actorAbilities) chaseFreq :: MonadActionRO m => m (Frequency CmdSerTakeTime) chaseFreq = do st <- chase aid (fpos, foeVisible) @@ -173,7 +173,7 @@ aStrategy Ability.Pickup = return mzero aStrategy Ability.Wander = wander aid aStrategy ab = assert `failure` "unexpected ability" - `with`(ab, actorAbilities) + `twith`(ab, actorAbilities) sumS abis = do fs <- mapM aStrategy abis return $ msum fs @@ -203,7 +203,7 @@ let clearPath = returN "ClearPathSer" $ SetPathSer aid [] strat = case bpath of Nothing -> reject - Just [] -> assert `failure` "null path" `with` (aid, b) + 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 @@ -215,7 +215,7 @@ body@Actor{bpos, blid} <- getsState $ getActorBody aid lvl <- getLevel blid actionPickup <- case EM.minViewWithKey $ lvl `atI` bpos of - Nothing -> assert `failure` "pickup of empty pile" `with` (aid, bpos, lvl) + Nothing -> assert `failure` "pickup of empty pile" `twith` (aid, bpos, lvl) Just ((iid, k), _) -> do -- pick up first item item <- getsState $ getItemBody iid let l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing @@ -516,7 +516,7 @@ -- 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" `with` (run, source, dir) + 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 @@ -527,7 +527,7 @@ else -- Boring tile, no point bumping into it, do WaitSer if really idle. assert `failure` "AI causes MoveNothing or AlterNothing" - `with` (run, source, dir) + `twith` (run, source, dir) -- | How much AI benefits from applying the effect. Multipllied by item p. -- Negative means harm to the enemy when thrown at him. Effects with zero 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 @@ -37,7 +37,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ActorKind -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar -- | A unique identifier of an actor in the dungeon. newtype ActorId = ActorId Int @@ -93,7 +93,7 @@ -- Actor operations --- | A template for a new non-projectile actor. +-- | A template for a new actor. actorTemplate :: Kind.Id ActorKind -> Char -> Text -> Color.Color -> Speed -> Int -> Maybe [Vector] -> Point -> LevelId -> Time -> FactionId -> Bool -> Actor @@ -216,9 +216,9 @@ rmFromBag :: Int -> ItemId -> ItemBag -> ItemBag rmFromBag k iid bag = - let rib Nothing = assert `failure` "rm from empty bag" `with` (k, iid, bag) + let rib Nothing = assert `failure` "rm from empty bag" `twith` (k, iid, bag) rib (Just n) = case compare n k of - LT -> assert `failure` "rm more than there is" `with` (n, k, iid, bag) + LT -> assert `failure` "rm more than there is" `twith` (n, k, iid, bag) EQ -> Nothing GT -> Just (n - k) in EM.alter rib iid bag 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 @@ -26,7 +26,7 @@ import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Content.TileKind -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar actorAssocs :: (FactionId -> Bool) -> LevelId -> State -> [(ActorId, Actor)] @@ -58,7 +58,7 @@ 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" `with` l) + in assert (length l <= 1 `blame` "many actors at the same position" `twith` l) $ listToMaybe l posToActors :: Point -> LevelId -> State -> [ActorId] @@ -117,7 +117,7 @@ tryFindHeroK s fact k = let c | k == 0 = '@' | k > 0 && k < 10 = Char.intToDigit k - | otherwise = assert `failure` "no digit" `with` k + | otherwise = assert `failure` "no digit" `twith` k in tryFindActor s (\body -> bsymbol body == c && not (bproj body) && bfid body == fact) @@ -139,12 +139,12 @@ i = fromMaybe defaultStairs mindex in case ascendInBranch dungeon lid k of [] | isNothing mindex -> (lid, pos) -- spell fizzles - [] -> assert `failure` "no dungeon level to go to" `with` (lid, pos, k) + [] -> assert `failure` "no dungeon level to go to" `twith` (lid, pos, k) ln : _ -> let lvlTgt = dungeon EM.! ln stairsTgt = (if k < 0 then fst else snd) (lstair lvlTgt) in if length stairsTgt < i + 1 then assert `failure` "no stairs at index" - `with` (lid, pos, k, ln, stairsTgt, i) + `twith` (lid, pos, k, ln, stairsTgt, i) else (ln, stairsTgt !! i) -- * The operations below disregard levels other than the current. @@ -152,12 +152,12 @@ -- | Gets actor body from the current level. Error if not found. getActorBody :: ActorId -> State -> Actor getActorBody aid s = - fromMaybe (assert `failure` "body not found" `with` (aid, s)) + fromMaybe (assert `failure` "body not found" `twith` (aid, s)) $ EM.lookup aid $ sactorD s updateActorBody :: ActorId -> (Actor -> Actor) -> State -> State updateActorBody aid f s = - let alt Nothing = assert `failure` "no body to update" `with` (aid, s) + let alt Nothing = assert `failure` "no body to update" `twith` (aid, s) alt (Just b) = Just $ f b in updateActorD (EM.alter alt aid) s @@ -168,7 +168,7 @@ actorContainer aid binv iid = case find ((== iid) . snd) $ EM.assocs binv of Just (l, _) -> CActor aid l - Nothing -> assert `failure` "item not in inventory" `with` (aid, binv, iid) + Nothing -> assert `failure` "item not in inventory" `twith` (aid, binv, iid) getActorInv :: ActorId -> State -> ItemInv getActorInv aid s = binv $ getActorBody aid s @@ -183,7 +183,7 @@ getItemBody :: ItemId -> State -> Item getItemBody iid s = fromMaybe (assert `failure` "item body not found" - `with` (iid, s)) $ EM.lookup iid $ sitemD s + `twith` (iid, s)) $ EM.lookup iid $ sitemD s -- | Checks if the actor is present on the current level. -- The order of argument here and in other functions is set to allow diff --git a/Game/LambdaHack/Common/Area.hs b/Game/LambdaHack/Common/Area.hs deleted file mode 100644 --- a/Game/LambdaHack/Common/Area.hs +++ /dev/null @@ -1,62 +0,0 @@ --- | Rectangular areas of levels and their basic operations. -module Game.LambdaHack.Common.Area - ( Area, vicinityXY, vicinityCardinalXY, insideXY - , normalizeArea, grid, validArea, trivialArea, expand - ) where - -import Game.LambdaHack.Common.PointXY -import Game.LambdaHack.Common.VectorXY - --- | The type of areas. The bottom left and the top right points. -type Area = (X, Y, X, Y) - --- | All (8 at most) closest neighbours of a point within an area. -vicinityXY :: Area -- ^ 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 :: Area -- ^ 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 ] - --- | Checks that a point belongs to an area. -insideXY :: PointXY -> Area -> Bool -insideXY (PointXY (x, y)) (x0, y0, x1, y1) = - x1 >= x && x >= x0 && y1 >= y && y >= y0 - --- | Sort the corners of an area so that the bottom left is the first point. -normalizeArea :: Area -> Area -normalizeArea (x0, y0, x1, y1) = (min x0 x1, min y0 y1, max x0 x1, max y0 y1) - --- | Divide uniformly a larger area into the given number of smaller areas. -grid :: (X, Y) -> Area -> [(PointXY, Area)] -grid (nx, ny) (x0, y0, x1, y1) = - let xd = x1 - x0 - yd = y1 - y0 - -- 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. - xborder = if nx == 1 then 3 else 2 - yborder = if ny == 1 then 3 else 2 - in [ (PointXY (x, y), (x0 + (xd * x `div` nx) + xborder, - y0 + (yd * y `div` ny) + yborder, - x0 + (xd * (x + 1) `div` nx) - xborder, - y0 + (yd * (y + 1) `div` ny) - yborder)) - | x <- [0..nx-1], y <- [0..ny-1] ] - --- | Checks if it's an area with at least one field. -validArea :: Area -> Bool -validArea (x0, y0, x1, y1) = x0 <= x1 && y0 <= y1 - --- | Checks if it's an area with exactly one field. -trivialArea :: Area -> Bool -trivialArea (x0, y0, x1, y1) = x0 == x1 && y0 == y1 - --- | Enlarge (or shrink) the given area on all fours sides by the amount. -expand :: Area -> Int -> Area -expand (x0, y0, x1, y1) k = (x0 - k, y0 - k, x1 + k, y1 + k) 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 @@ -18,7 +18,7 @@ import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar -- All functions here that take an atomic action are executed -- in the state just before the action is executed. @@ -235,11 +235,11 @@ PosFidAndSer fid2 -> fid == fid2 PosSer -> False PosAll -> True - PosNone -> assert `failure` "no position possible" `with` fid + PosNone -> assert `failure` "no position possible" `twith` fid seenAtomicSer :: PosAtomic -> Bool seenAtomicSer posAtomic = case posAtomic of PosFid _ -> False - PosNone -> assert `failure` "wrong position for server" `with` posAtomic + PosNone -> assert `failure` "wrong position for server" `twith` posAtomic _ -> True 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 @@ -11,6 +11,7 @@ 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 @@ -27,7 +28,6 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.TileKind as TileKind -import Game.LambdaHack.Utils.Assert cmdAtomicSem :: MonadAction m => CmdAtomic -> m () cmdAtomicSem cmd = case cmd of @@ -80,12 +80,12 @@ createActorA aid body ais = do -- Add actor to @sactorD@. let f Nothing = Just body - f (Just b) = assert `failure` "actor already added" `with` (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] g (Just l) = assert (aid `notElem` l `blame` "actor already added" - `with` (aid, body, l)) + `twith` (aid, body, l)) $ Just $ aid : l updateLevel (blid body) $ updatePrio $ EM.alter g (btime body) -- Actor's items may or may not be already present in @sitemD@, @@ -94,32 +94,36 @@ forM_ ais $ \(iid, item) -> do let h item1 item2 = assert (item1 == item2 `blame` "inconsistent created actor items" - `with` (aid, body, iid, item1, item2)) item1 + `twith` (aid, body, iid, item1, item2)) item1 modifyState $ updateItemD $ EM.insertWith h iid item -- | Update a given level data within state. updateLevel :: MonadAction m => LevelId -> (Level -> Level) -> m () updateLevel lid f = modifyState $ updateDungeon $ EM.adjust f lid --- | Kills an actor. Note: after this command, usually a new leader --- for the party should be elected. +-- | Kills an actor. destroyActorA :: MonadAction m => ActorId -> Actor -> [(ItemId, Item)] -> m () destroyActorA aid body ais = do + -- If a leader dies, a new leader should be elected on the server + -- before this command is executed. + -- TODO: check this only on the server (e.g., not in LoseActor): + -- fact <- getsState $ (EM.! bfid body) . sfactionD + -- assert (Just aid /= gleader fact `blame` (aid, body, fact)) skip -- Assert that actor's items belong to @sitemD@. Do not remove those -- that do not appear anywhere else, for simplicity and speed. itemD <- getsState sitemD let match (iid, item) = itemD EM.! iid == item assert (allB match ais `blame` "destroyed actor items not found" - `with` (aid, body, ais, itemD)) skip + `twith` (aid, body, ais, itemD)) skip -- Remove actor from @sactorD@. - let f Nothing = assert `failure` "actor already removed" `with` (aid, body) + let f Nothing = assert `failure` "actor already removed" `twith` (aid, body) f (Just b) = assert (b == body `blame` "inconsisted destroyed actor body" - `with` (aid, body, b)) Nothing + `twith` (aid, body, b)) Nothing modifyState $ updateActorD $ EM.alter f aid -- Remove actor from @sprio@. - let g Nothing = assert `failure` "actor already removed" `with` (aid, body) + let g Nothing = assert `failure` "actor already removed" `twith` (aid, body) g (Just l) = assert (aid `elem` l `blame` "actor already removed" - `with` (aid, body, l)) + `twith` (aid, body, l)) $ let l2 = delete aid l in if null l2 then Nothing else Just l2 updateLevel (blid body) $ updatePrio $ EM.alter g (btime body) @@ -132,7 +136,7 @@ -- regardless if it's actually present in the dungeon. let f item1 item2 = assert (item1 == item2 `blame` "inconsistent created item" - `with` (iid, item, k, c)) item1 + `twith` (iid, item, k, c)) item1 modifyState $ updateItemD $ EM.insertWith f iid item case c of CFloor lid pos -> insertItemFloor lid iid k pos @@ -150,12 +154,10 @@ insertItemActor iid k l aid = do let bag = EM.singleton iid k upd = EM.unionWith (+) bag - modifyState $ updateActorD $ - EM.adjust (\b -> b {bbag = upd (bbag b)}) aid - modifyState $ updateActorD $ - EM.adjust (\b -> b {binv = EM.insert l iid (binv b)}) aid modifyState $ updateActorBody aid $ \b -> - b {bletter = max l (bletter b)} + b { bbag = upd (bbag b) + , binv = EM.insert l iid (binv b) + , bletter = max l (bletter b) } -- | Destroy some copies (possibly not all) of an item. destroyItemA :: MonadAction m => ItemId -> Item -> Int -> Container -> m () @@ -165,7 +167,7 @@ -- However, assert the item is registered in @sitemD@. itemD <- getsState sitemD assert (iid `EM.lookup` itemD == Just item `blame` "item already removed" - `with` (iid, item, itemD)) skip + `twith` (iid, item, itemD)) skip case c of CFloor lid pos -> deleteItemFloor lid iid k pos CActor aid l -> deleteItemActor iid k l aid @@ -177,27 +179,27 @@ let nbag = rmFromBag k iid bag in if EM.null nbag then Nothing else Just nbag rmFromFloor Nothing = assert `failure` "item already removed" - `with` (lid, iid, k, pos) + `twith` (lid, iid, k, pos) in updateLevel lid $ updateFloor $ EM.alter rmFromFloor pos deleteItemActor :: MonadAction m => ItemId -> Int -> InvChar -> ActorId -> m () deleteItemActor iid k l aid = do - modifyState $ updateActorD $ - EM.adjust (\b -> b {bbag = rmFromBag k iid (bbag b)}) aid + modifyState $ updateActorBody aid $ \b -> + b {bbag = rmFromBag k iid (bbag b)} -- Do not remove from actor's @binv@, but assert it was there. b <- getsState $ getActorBody aid assert (l `EM.lookup` binv b == Just iid `blame` "item already removed" - `with` (iid, l, aid)) skip + `twith` (iid, l, aid)) skip -- Actor's @bletter@ for UI not reset, but checked. assert (bletter b >= l`blame` "inconsistent actor inventory letter" - `with` (iid, k, l, aid, bletter b)) skip + `twith` (iid, k, l, aid, bletter b)) skip moveActorA :: MonadAction m => ActorId -> Point -> Point -> m () moveActorA aid fromP toP = assert (fromP /= toP) $ do b <- getsState $ getActorBody aid assert (fromP == bpos b `blame` "unexpected moved actor position" - `with` (aid, fromP, toP, bpos b, b)) skip + `twith` (aid, fromP, toP, bpos b, b)) skip modifyState $ updateActorBody aid $ \body -> body {bpos = toP, boldpos = fromP} @@ -205,7 +207,7 @@ waitActorA aid fromWait toWait = assert (fromWait /= toWait) $ do b <- getsState $ getActorBody aid assert (fromWait == bwait b `blame` "unexpected waited actor time" - `with` (aid, fromWait, toWait, bwait b, b)) skip + `twith` (aid, fromWait, toWait, bwait b, b)) skip modifyState $ updateActorBody aid $ \body -> body {bwait = toWait} displaceActorA :: MonadAction m => ActorId -> ActorId -> m () @@ -220,7 +222,7 @@ (lid1, _) <- posOfContainer c1 (lid2, _) <- posOfContainer c2 assert (lid1 == lid2 `blame` "moved item containers not on the same level" - `with` (iid, k, c1, c2, lid1, lid2)) skip + `twith` (iid, k, c1, c2, lid1, lid2)) skip case c1 of CFloor lid pos -> deleteItemFloor lid iid k pos CActor aid l -> deleteItemActor iid k l aid @@ -259,7 +261,7 @@ modifyState $ updateActorBody aid $ \ b -> let newSpeed = speedAdd (bspeed b) delta in assert (newSpeed >= speedZero `blame` "actor slowed below zero" - `with` (aid, delta, bspeed b, newSpeed)) $ + `twith` (aid, delta, bspeed b, newSpeed)) $ b {bspeed = newSpeed} pathActorA :: MonadAction m @@ -267,7 +269,7 @@ pathActorA aid fromPath toPath = assert (fromPath /= toPath) $ do body <- getsState $ getActorBody aid assert (fromPath == bpath body `blame` "unexpected actor path" - `with` (aid, fromPath, toPath, body)) skip + `twith` (aid, fromPath, toPath, body)) skip modifyState $ updateActorBody aid $ \b -> b {bpath = toPath} colorActorA :: MonadAction m @@ -275,7 +277,7 @@ colorActorA aid fromCol toCol = assert (fromCol /= toCol) $ do body <- getsState $ getActorBody aid assert (fromCol == bcolor body `blame` "unexpected actor color" - `with` (aid, fromCol, toCol, body)) skip + `twith` (aid, fromCol, toCol, body)) skip modifyState $ updateActorBody aid $ \b -> b {bcolor = toCol} quitFactionA :: MonadAction m @@ -285,7 +287,7 @@ assert (maybe True ((fid ==) . bfid) mbody) skip fact <- getsState $ (EM.! fid) . sfactionD assert (fromSt == gquit fact `blame` "unexpected actor quit status" - `with` (fid, fromSt, toSt, fact)) skip + `twith` (fid, fromSt, toSt, fact)) skip let adj fa = fa {gquit = toSt} modifyState $ updateFaction $ EM.adjust adj fid @@ -294,8 +296,11 @@ => FactionId -> Maybe ActorId -> Maybe ActorId -> m () leadFactionA fid source target = assert (source /= target) $ do fact <- getsState $ (EM.! fid) . sfactionD + mtb <- getsState $ \s -> fmap (flip getActorBody s) target + assert (maybe True (not . bproj) mtb + `blame` (fid, source, target, mtb, fact)) skip assert (source == gleader fact `blame` "unexpected actor leader" - `with` (fid, source, target, fact)) skip + `twith` (fid, source, target, mtb, fact)) skip let adj fa = fa {gleader = target} modifyState $ updateFaction $ EM.adjust adj fid @@ -308,7 +313,7 @@ assert (fromDipl == EM.findWithDefault Unknown fid2 (gdipl fact1) && fromDipl == EM.findWithDefault Unknown fid1 (gdipl fact2) `blame` "unexpected actor diplomacy status" - `with` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) skip + `twith` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) skip let adj fid fact = fact {gdipl = EM.insert fid toDipl (gdipl fact)} modifyState $ updateFaction $ EM.adjust (adj fid2) fid1 modifyState $ updateFaction $ EM.adjust (adj fid1) fid2 @@ -330,7 +335,7 @@ let adj ts = assert (ts Kind.! p == fromTile || ts Kind.! p == freshClientTile `blame` "unexpected altered tile kind" - `with` (lid, p, fromTile, toTile, ts Kind.! p)) + `twith` (lid, p, fromTile, toTile, ts Kind.! p)) $ ts Kind.// [(p, toTile)] updateLevel lid $ updateTile adj case (Tile.isExplorable cotile fromTile, Tile.isExplorable cotile toTile) of @@ -380,7 +385,7 @@ 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" - -- `with` (lid, p, fromSm, toSm, sm)) toSm + -- `twith` (lid, p, fromSm, toSm, sm)) toSm let alt _ = toSm updateLevel lid $ updateSmell $ EM.alter alt p @@ -391,7 +396,7 @@ -- TODO: a hack to sidestep server not disabling the nose of fresh actors, -- see smellFromActors -- alt sm (Just oldSm) = assert `failure` "smell already added" --- `with` (lid, sms, sm, oldSm) +-- `twith` (lid, sms, sm, oldSm) f (p, sm) = EM.alter (alt sm) p upd m = foldr f m sms updateLevel lid $ updateSmell upd @@ -399,10 +404,10 @@ loseSmellA :: MonadAction m => LevelId -> [(Point, Time)] -> m () loseSmellA lid sms = assert (not $ null sms) $ do let alt sm Nothing = assert `failure` "smell already removed" - `with` (lid, sms, sm) + `twith` (lid, sms, sm) alt sm (Just oldSm) = assert (sm == oldSm `blame` "unexpected lost smell" - `with` (lid, sms, sm, oldSm)) Nothing + `twith` (lid, sms, sm, oldSm)) Nothing f (p, sm) = EM.alter (alt sm) p upd m = foldr f m sms updateLevel lid $ updateSmell upd diff --git a/Game/LambdaHack/Common/ConfigIO.hs b/Game/LambdaHack/Common/ConfigIO.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Common/ConfigIO.hs @@ -0,0 +1,97 @@ +-- | 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 @@ -13,7 +13,7 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Random -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar -- TODO: document each constructor -- Effects of items, tiles, etc. The type argument represents power. @@ -89,7 +89,7 @@ affixPower :: Int -> Text affixPower p = case compare p 1 of EQ -> "" - LT -> assert `failure` "power less than 1" `with` p + LT -> assert `failure` "power less than 1" `twith` p GT -> " (+" <> showT p <> ")" affixBonus :: Int -> Text 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 @@ -60,13 +60,13 @@ -- | Tell whether the faction can spawn actors. isSpawnFact :: Kind.COps -> Faction -> Bool -isSpawnFact Kind.COps{cofact=Kind.Ops{okind}} fact = +isSpawnFact Kind.COps{cofaction=Kind.Ops{okind}} fact = let kind = okind (gkind fact) in maybe False (> 0) $ lookup "spawn" $ ffreq kind -- | Tell whether actors of the faction can be summoned by items, etc. isSummonFact :: Kind.COps -> Faction -> Bool -isSummonFact Kind.COps{cofact=Kind.Ops{okind}} fact = +isSummonFact Kind.COps{cofaction=Kind.Ops{okind}} fact = let kind = okind (gkind fact) in maybe False (> 0) $ lookup "summon" $ ffreq kind 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 @@ -23,6 +23,7 @@ import qualified Data.Hashable as Hashable import qualified Data.Ix as Ix import Data.List +import Data.Maybe import qualified Data.Set as S import Data.Text (Text) import GHC.Generics (Generic) @@ -36,7 +37,8 @@ import Game.LambdaHack.Common.Random import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar +import Game.LambdaHack.Utils.Frequency -- | A unique identifier of an item in the dungeon. newtype ItemId = ItemId Int @@ -88,7 +90,7 @@ let f ik _ (ikMap, ikRev, ix : rest) = (EM.insert ix ik ikMap, EM.insert ik ix ikRev, rest) f ik _ (ikMap, _, []) = - assert `failure` "too short ixs" `with` (ik, ikMap) + assert `failure` "too short ixs" `twith` (ik, ikMap) (discoS, discoRev, _) = ofoldrWithKey f (EM.empty, EM.empty, shuffled) return (discoS, discoRev) @@ -107,20 +109,30 @@ in Item{..} -- | Generate an item based on level. -newItem :: Kind.Ops ItemKind -> FlavourMap -> DiscoRev -> Int -> Int +newItem :: Kind.Ops ItemKind -> FlavourMap -> DiscoRev + -> Frequency Text -> Int -> Int -> Rnd (Item, Int, ItemKind) -newItem cops@Kind.Ops{opick, okind} flavour discoRev lvl depth = do - ikChosen <- opick "dng" (const True) - let kind = okind ikChosen - jcount <- castDeep lvl depth (icount kind) - if jcount == 0 - then -- Rare item; beware of inifite loops. - newItem cops flavour discoRev lvl depth - else do - effect <- effectTrav (ieffect kind) (castDeep lvl depth) - return ( buildItem flavour discoRev ikChosen kind effect - , jcount - , kind ) +newItem cops@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 + castItem count = do + ikChosen <- fmap (fromMaybe $ assert `failure` itemGroup) + $ opick itemGroup (const True) + let kind = okind ikChosen + jcount <- castDeep lvl depth (icount kind) + if jcount == 0 then + castItem $ count - 1 + else do + effect <- effectTrav (ieffect kind) (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) 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 @@ -29,7 +29,7 @@ import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency -- | Content identifiers for the content type @c@. @@ -57,7 +57,7 @@ { okind :: Id a -> a -- ^ the content element at given id , ouniqGroup :: Text -> Id a -- ^ the id of the unique member of -- a singleton content group - , opick :: Text -> (a -> Bool) -> Rnd (Id a) + , opick :: Text -> (a -> Bool) -> Rnd (Maybe (Id a)) -- ^ pick a random id belonging to a group -- and satisfying a predicate , ofoldrWithKey :: forall b. (Id a -> a -> b -> b) -> b -> b @@ -82,32 +82,31 @@ lists = L.foldl' f M.empty tuples nameFreq group = toFreq $ "opick ('" <> group <> "')" in M.mapWithKey nameFreq lists - okind i = fromMaybe (assert `failure` "no kind" `with` (i, kindMap)) + 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) offenders = validate content in assert (allB correct content) $ - assert (L.null offenders `blame` "content not valid" `with` offenders) + assert (L.null offenders `blame` "content not valid" `twith` offenders) -- By this point 'content' can be GCd. Ops { okind , ouniqGroup = \group -> let freq = fromMaybe (assert `failure` "no unique group" - `with` (group, kindFreq)) + `twith` (group, kindFreq)) $ M.lookup group kindFreq in case runFrequency freq of [(n, (i, _))] | n > 0 -> i - l -> assert `failure` "not unique" `with` (l, group, kindFreq) + l -> assert `failure` "not unique" `twith` (l, group, kindFreq) , opick = \group p -> - let freq = fromMaybe (assert `failure` "no group to pick from" - `with` (group, kindFreq)) - $ M.lookup group kindFreq - in frequency $ do - (i, k) <- freq - breturn (p k) i - {- with MonadComprehensions: - frequency [ i | (i, k) <- kindFreq M.! group, p k ] - -} + case M.lookup group 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 ] + -} + _ -> return Nothing , ofoldrWithKey = \f z -> L.foldr (\(i, a) -> f i a) z $ EM.assocs kindMap , obounds = ( fst $ EM.findMin kindMap @@ -117,14 +116,14 @@ -- | Operations for all content types, gathered together. data COps = COps - { coactor :: !(Ops ActorKind) - , cocave :: !(Ops CaveKind) - , cofact :: !(Ops FactionKind) - , coitem :: !(Ops ItemKind) - , comode :: !(Ops ModeKind) - , coplace :: !(Ops PlaceKind) - , corule :: !(Ops RuleKind) - , cotile :: !(Ops TileKind) + { coactor :: !(Ops ActorKind) + , cocave :: !(Ops CaveKind) + , cofaction :: !(Ops FactionKind) + , coitem :: !(Ops ItemKind) + , comode :: !(Ops ModeKind) + , coplace :: !(Ops PlaceKind) + , corule :: !(Ops RuleKind) + , cotile :: !(Ops TileKind) } -- | The standard ruleset used for level operations. 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 @@ -35,7 +35,8 @@ import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind -import Game.LambdaHack.Utils.Assert +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 @@ -47,7 +48,7 @@ let (minD, maxD) = case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) - _ -> assert `failure` "null dungeon" `with` dungeon + _ -> assert `failure` "null dungeon" `twith` dungeon ln = max minD $ min maxD $ toEnum $ fromEnum lid + k in case EM.lookup ln dungeon of Just _ | ln /= lid -> [ln] @@ -76,22 +77,24 @@ -- | A view on single, inhabited dungeon level. "Remembered" fields -- carry a subset of the info in the client copies of levels. data Level = Level - { ldepth :: !Int -- ^ depth of the level - , lprio :: !ActorPrio -- ^ remembered actor times on the level - , lfloor :: !ItemFloor -- ^ remembered items lying on the floor - , ltile :: !TileMap -- ^ remembered level map - , lxsize :: !X -- ^ width of the level - , lysize :: !Y -- ^ height of the level - , lsmell :: !SmellMap -- ^ remembered smells on the level - , ldesc :: !Text -- ^ level description - , lstair :: !([Point], [Point]) + { ldepth :: !Int -- ^ depth of the level + , lprio :: !ActorPrio -- ^ remembered actor times on the level + , lfloor :: !ItemFloor -- ^ remembered items lying on the floor + , ltile :: !TileMap -- ^ remembered level map + , lxsize :: !X -- ^ width of the level + , lysize :: !Y -- ^ height of the level + , lsmell :: !SmellMap -- ^ remembered smells on the level + , ldesc :: !Text -- ^ level description + , lstair :: !([Point], [Point]) -- ^ destinations of (up, down) stairs - , lseen :: !Int -- ^ currently remembered clear tiles - , lclear :: !Int -- ^ total number of initially clear tiles - , ltime :: !Time -- ^ date of the last activity on the level - , litemNum :: !Int -- ^ number of initial items, 0 for clients - , lsecret :: !Int -- ^ secret tile seed - , lhidden :: !Int -- ^ secret tile density + , lseen :: !Int -- ^ currently remembered clear tiles + , lclear :: !Int -- ^ total number of initially clear tiles + , 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 } deriving (Show, Eq) @@ -113,42 +116,8 @@ assertSparseItems :: ItemFloor -> ItemFloor assertSparseItems m = - assert (EM.null (EM.filter EM.null m) `blame` "null floors found" `with` m) m - -instance Binary Level where - put Level{..} = do - put ldepth - put lprio - put (assertSparseItems lfloor) - put ltile - put lxsize - put lysize - put lsmell - put ldesc - put lstair - put lseen - put lclear - put ltime - put litemNum - put lsecret - put lhidden - get = do - ldepth <- get - lprio <- get - lfloor <- get - ltile <- get - lxsize <- get - lysize <- get - lsmell <- get - ldesc <- get - lstair <- get - lseen <- get - lclear <- get - ltime <- get - litemNum <- get - lsecret <- get - lhidden <- get - return Level{..} + assert (EM.null (EM.filter EM.null m) + `blame` "null floors found" `twith` m) m -- | Query for tile kinds on the map. at :: Level -> Point -> Kind.Id TileKind @@ -205,16 +174,16 @@ -- at which point try as many times, as needed. findPosTry :: Int -- ^ the number of tries -> TileMap -- ^ look up in this map - -> [Point -> Kind.Id TileKind -> Bool] -- ^ predicates to satisfy + -> (Point -> Kind.Id TileKind -> Bool) -- ^ mandatory predicate + -> [Point -> Kind.Id TileKind -> Bool] -- ^ optional predicates -> Rnd Point -findPosTry _ ltile [] = findPos ltile (const (const True)) -findPosTry _ ltile [p] = findPos ltile p -findPosTry numTries ltile l@(_ : tl) = assert (numTries > 0) $ - let search 0 = findPosTry numTries ltile tl +findPosTry _ ltile m [] = findPos ltile m +findPosTry numTries ltile m l@(_ : tl) = assert (numTries > 0) $ + let search 0 = findPosTry numTries ltile m tl search k = do pos <- randomR $ Kind.bounds ltile let tile = ltile Kind.! pos - if L.all (\ p -> p pos tile) l + if m pos tile && L.all (\p -> p pos tile) l then return pos else search (k - 1) in search numTries @@ -228,3 +197,40 @@ mapDungeonActors_ f dungeon = do let ls = EM.elems dungeon mapM_ (mapLevelActors_ f) ls + +instance Binary Level where + put Level{..} = do + put ldepth + put lprio + put (assertSparseItems lfloor) + put ltile + put lxsize + put lysize + put lsmell + put ldesc + put lstair + put lseen + put lclear + put ltime + put litemNum + put litemFreq + put lsecret + put lhidden + get = do + ldepth <- get + lprio <- get + lfloor <- get + ltile <- get + lxsize <- get + lysize <- get + lsmell <- get + ldesc <- get + lstair <- get + lseen <- get + lclear <- get + ltime <- get + litemNum <- get + litemFreq <- get + lsecret <- get + lhidden <- get + return Level{..} 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 @@ -12,11 +12,10 @@ import Data.Text (Text) import qualified System.Random as R -import Game.LambdaHack.Common.Area import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.VectorXY -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar -- | The type of positions on the 2D level map, heavily optimized. -- @@ -49,13 +48,13 @@ toPoint :: X -> PointXY -> Point toPoint lxsize (PointXY (x, y)) = assert (lxsize > x && x >= 0 && y >= 0 `blame` "invalid point coordinates" - `with` (lxsize, x, y)) + `twith` (lxsize, x, y)) $ Point $ x + y * lxsize -- | Conversion from @Point@ to cartesian coordinates. fromPoint :: X -> Point -> PointXY fromPoint lxsize (Point p) = - assert (p >= 0 `blame` "negative point value" `with` (lxsize, p)) + assert (p >= 0 `blame` "negative point value" `twith` (lxsize, p)) $ PointXY (p `rem` lxsize, p `quot` lxsize) -- | The top-left corner position of the level. @@ -90,7 +89,7 @@ fromPoint lxsize p -- | Checks that a point belongs to an area. -inside :: X -> Point -> Area -> Bool +inside :: X -> Point -> (X, Y, X, Y) -> Bool inside lxsize p = insideXY $ fromPoint lxsize p -- | Calculate the displacement vector from a position to another. diff --git a/Game/LambdaHack/Common/PointXY.hs b/Game/LambdaHack/Common/PointXY.hs --- a/Game/LambdaHack/Common/PointXY.hs +++ b/Game/LambdaHack/Common/PointXY.hs @@ -1,12 +1,12 @@ -- | Basic cartesian geometry operations on 2D points. module Game.LambdaHack.Common.PointXY - ( X, Y, PointXY(..), fromTo, sortPointXY, blaXY + ( X, Y, PointXY(..), fromTo, sortPointXY, blaXY, insideXY ) where import qualified Data.List as L import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar -- | Spacial dimension for points and vectors. type X = Int @@ -41,7 +41,7 @@ | 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" - `with` ((x0, y0), (x1, y1)) + `twith` ((x0, y0), (x1, y1)) in result fromTo1 :: Int -> Int -> [Int] @@ -72,3 +72,8 @@ 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 @@ -8,9 +8,9 @@ -- * Casting dice , RollDice, rollDice, castDice, maxDice, minDice, meanDice -- * Casting 2D coordinates - , RollDiceXY(..), castDiceXY + , RollDiceXY, rollDiceXY, castDiceXY, maxDiceXY, minDiceXY, meanDiceXY -- * Casting dependent on depth - , RollDeep, castDeep, chanceDeep, intToDeep, maxDeep + , RollDeep, rollDeep, castDeep, chanceDeep, intToDeep, maxDeep -- * Fractional chance , Chance, chance -- * Run using the IO RNG @@ -27,7 +27,7 @@ import GHC.Generics (Generic) import qualified System.Random as R -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency -- | The monad of computations with random generator state. @@ -44,7 +44,7 @@ -- | Get any element of a list with equal probability. oneOf :: [a] -> Rnd a -oneOf [] = assert `failure` "oneOf []" `with` () +oneOf [] = assert `failure` "oneOf []" `twith` () oneOf xs = do r <- randomR (0, length xs - 1) return (xs !! r) @@ -79,7 +79,7 @@ rollDice :: Int -> Int -> RollDice rollDice a b = assert (a >= 0 && a <= 255 && b >= 0 && b <= 255 - `blame` "dice out of bounds" `with` (a, b)) + `blame` "dice out of bounds" `twith` (a, b)) $ RollDice (toEnum a) (toEnum b) -- | Cast dice and sum the results. @@ -109,29 +109,49 @@ -- | Dice for rolling a pair of integer parameters pertaining to, -- respectively, the X and Y cartesian 2D coordinates. -data RollDiceXY = RollDiceXY !(RollDice, RollDice) +data RollDiceXY = RollDiceXY ![RollDice] ![RollDice] deriving Show +rollDiceXY :: [(Int, Int)] -> [(Int, Int)] -> RollDiceXY +rollDiceXY lx ly = RollDiceXY (map (uncurry rollDice) lx) + (map (uncurry rollDice) ly) + -- | Cast the two sets of dice. castDiceXY :: RollDiceXY -> Rnd (Int, Int) -castDiceXY (RollDiceXY (xd, yd)) = do - x <- castDice xd - y <- castDice yd - return (x, y) +castDiceXY (RollDiceXY lx ly) = do + cx <- mapM castDice lx + cy <- mapM castDice ly + return (sum cx, sum cy) +-- | Maximal value of RollDiceXY. +maxDiceXY :: RollDiceXY -> (Int, Int) +maxDiceXY (RollDiceXY lx ly) = (sum (map maxDice lx), sum (map maxDice ly)) + +-- | Minimal value of RollDiceXY. +minDiceXY :: RollDiceXY -> (Int, Int) +minDiceXY (RollDiceXY lx ly) = (sum (map minDice lx), sum (map minDice ly)) + +-- | Mean value of RollDiceXY. +meanDiceXY :: RollDiceXY -> (Rational, Rational) +meanDiceXY (RollDiceXY lx ly) = (sum (map meanDice lx), sum (map meanDice ly)) + -- | Dice for parameters scaled with current level depth. -- 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. -type RollDeep = (RollDice, RollDice) +data RollDeep = RollDeep !RollDice !RollDice + deriving Show +rollDeep :: (Int, Int) -> (Int, Int) -> RollDeep +rollDeep (a, b) (c, d) = RollDeep (rollDice a b) (rollDice c d) + -- | Cast dice scaled with current level depth. -- Note that at the first level, the scaled dice are always ignored. castDeep :: Int -> Int -> RollDeep -> Rnd Int -castDeep n' depth' (d1, d2) = do +castDeep n' depth' (RollDeep d1 d2) = do let n = abs n' depth = abs depth' assert (n > 0 && n <= depth `blame` "invalid current depth for dice rolls" - `with` (n, depth)) skip + `twith` (n, depth)) skip r1 <- castDice d1 r2 <- castDice d2 return $ r1 + ((n - 1) * r2) `div` max 1 (depth - 1) @@ -147,15 +167,15 @@ -- | Generate a @RollDeep@ that always gives a constant integer. intToDeep :: Int -> RollDeep -intToDeep 0 = (RollDice 0 0, RollDice 0 0) +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" `with` n' - else (RollDice n 1, RollDice 0 0) + then assert `failure` "Deep out of bound" `twith` n' + else RollDeep (RollDice n 1) (RollDice 0 0) -- | Maximal value of scaled dice. maxDeep :: RollDeep -> Int -maxDeep (d1, d2) = maxDice d1 + maxDice d2 +maxDeep (RollDeep d1 d2) = maxDice d1 + maxDice d2 -- | Fractional chance. type Chance = Rational 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 @@ -83,7 +83,7 @@ restoreGame name configAppDataDir copies pathsDataFile = do -- Create user data directory and copy files, if not already there. tryCreateDir configAppDataDir - tryCopyDataFiles pathsDataFile copies + tryCopyDataFiles configAppDataDir pathsDataFile copies let saveFile = configAppDataDir name saveExists <- doesFileExist saveFile -- If the savefile exists but we get IO or decoding errors, 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 @@ -22,7 +22,6 @@ | GameRestartSer !ActorId !Text | GameExitSer !ActorId | GameSaveSer !ActorId - | CfgDumpSer !ActorId deriving (Show, Eq) data CmdSerTakeTime = @@ -47,7 +46,6 @@ GameRestartSer aid _ -> aid GameExitSer aid -> aid GameSaveSer aid -> aid - CfgDumpSer aid -> aid aidCmdSerTakeTime :: CmdSerTakeTime -> ActorId aidCmdSerTakeTime cmd = case cmd of 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 @@ -24,6 +24,7 @@ import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.TileKind +import Game.LambdaHack.Utils.Frequency -- | View on game state. "Remembered" fields carry a subset of the info -- in the client copies of the state. Clients never directly change @@ -61,6 +62,7 @@ , lclear , ltime = timeTurn , litemNum = 0 + , litemFreq = toFreq "client item freq" [] , lsecret , lhidden } 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 @@ -21,13 +21,14 @@ import qualified Data.Array.Unboxed as A import qualified Data.List as L +import Data.Maybe 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 Game.LambdaHack.Utils.Assert +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. @@ -52,13 +53,13 @@ -- Essential for efficiency of "FOV", hence tabulated. isClear :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool isClear Kind.Ops{ospeedup = Just Kind.TileSpeedup{isClearTab}} = isClearTab -isClear cotile = assert `failure` "no speedup" `with` Kind.obounds cotile +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 -isLit cotile = assert `failure` "no speedup" `with` Kind.obounds cotile +isLit cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile -- | Whether a tile can be explored, possibly yielding a treasure -- or a hidden message. @@ -95,7 +96,8 @@ [] -> return t groups -> do group <- oneOf groups - opick group (const True) + fmap (fromMaybe $ assert `failure` group) + $ opick group (const True) closeTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) closeTo Kind.Ops{okind, opick} t = do @@ -105,7 +107,8 @@ [] -> return t groups -> do group <- oneOf groups - opick group (const True) + fmap (fromMaybe $ assert `failure` group) + $ opick group (const True) revealAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) revealAs Kind.Ops{okind, opick} t = do @@ -115,7 +118,8 @@ [] -> return t groups -> do group <- oneOf groups - opick group (const True) + fmap (fromMaybe $ assert `failure` group) + $ opick group (const True) hideAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind hideAs Kind.Ops{okind, ouniqGroup} t = 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 @@ -8,11 +8,10 @@ import Data.Binary -import Game.LambdaHack.Common.Area import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.VectorXY -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar -- | 2D vectors represented as offsets in the linear framebuffer -- indexed by 'Point'. @@ -49,7 +48,7 @@ toDir :: X -> VectorXY -> Vector toDir lxsize v@(VectorXY (x, y)) = assert (lxsize >= 3 && isUnitXY v `blame` "ambiguous XY vector conversion" - `with` (lxsize, v)) $ + `twith` (lxsize, v)) $ Vector $ x + y * lxsize -- | Converts a unit vector in the offset representation @@ -59,7 +58,7 @@ fromDir lxsize (Vector dir) = assert (lxsize >= 3 && isUnitXY res && fst len1 + snd len1 * lxsize == dir - `blame` "ambiguous vector conversion" `with` (lxsize, dir, res)) + `blame` "ambiguous vector conversion" `twith` (lxsize, dir, res)) res where (x, y) = (dir `mod` lxsize, dir `div` lxsize) @@ -76,7 +75,7 @@ shift p (Vector dir) = toEnum $ fromEnum p + dir -- | Translate a point by a vector, but only if the result fits in an area. -shiftBounded :: X -> Area -> Point -> Vector -> Point +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 @@ -110,7 +109,7 @@ -- (in the euclidean metric) maximally align with the original vector. normalize :: X -> VectorXY -> Vector normalize lxsize v@(VectorXY (dx, dy)) = - assert (dx /= 0 || dy /= 0 `blame` "can't normalize zero" `with` (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) dxy | angle <= -0.75 && angle >= -1.25 = (0, -1) @@ -119,13 +118,13 @@ | angle <= 0.75 = (1, 1) | angle <= 1.25 = (0, 1) | otherwise = assert `failure` "impossible angle" - `with` (lxsize, dx, dy, angle) + `twith` (lxsize, dx, dy, angle) rxy = if dx >= 0 then VectorXY dxy else negXY $ VectorXY dxy in assert (not (isUnitXY v) || v == rxy `blame` "unit vector gets untrivially normalized" - `with` (v, rxy)) + `twith` (v, rxy)) $ toDir lxsize rxy -- TODO: Perhaps produce all acceptable directions and let AI choose. @@ -140,7 +139,7 @@ -- the two points. towards :: X -> Point -> Point -> Vector towards lxsize pos0 pos1 = - assert (pos0 /= pos1 `blame` "towards self" `with` (pos0, pos1)) $ + assert (pos0 /= pos1 `blame` "towards self" `twith` (pos0, pos1)) $ let v = displacementXYZ lxsize pos0 pos1 in normalize lxsize v diff --git a/Game/LambdaHack/Common/VectorXY.hs b/Game/LambdaHack/Common/VectorXY.hs --- a/Game/LambdaHack/Common/VectorXY.hs +++ b/Game/LambdaHack/Common/VectorXY.hs @@ -2,7 +2,7 @@ -- | Basic cartesian geometry operations on 2D vectors. module Game.LambdaHack.Common.VectorXY ( VectorXY(..), shiftXY, movesXY, movesCardinalXY - , chessDistXY, euclidDistSqXY, negXY + , chessDistXY, euclidDistSqXY, negXY, vicinityXY, vicinityCardinalXY ) where import Data.Binary @@ -40,3 +40,18 @@ -- | 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/CaveKind.hs b/Game/LambdaHack/Content/CaveKind.hs --- a/Game/LambdaHack/Content/CaveKind.hs +++ b/Game/LambdaHack/Content/CaveKind.hs @@ -20,36 +20,49 @@ , cysize :: !Y -- ^ Y size of the whole cave , cgrid :: !RollDiceXY -- ^ the dimensions of the grid of places , cminPlaceSize :: !RollDiceXY -- ^ minimal size of places + , cmaxPlaceSize :: !RollDiceXY -- ^ maximal size of places , cdarkChance :: !RollDeep -- ^ the chance a place is dark + , cnightChance :: !RollDeep -- ^ the chance the cave is dark , cauxConnects :: !Rational -- ^ a proportion of extra connections - , cvoidChance :: !Chance -- ^ the chance of not creating a place - , cnonVoidMin :: !Int -- ^ extra places, may overlap except two + , cmaxVoid :: !Rational -- ^ at most this proportion of rooms void , cminStairDist :: !Int -- ^ minimal distance between stairs , cdoorChance :: !Chance -- ^ the chance of a door in an opening , copenChance :: !Chance -- ^ if there's a door, is it open? , chidden :: !Int -- ^ if not open, hidden one in n times , citemNum :: !RollDice -- ^ the number of items in the cave + , citemFreq :: ![(Int, Text)] -- ^ item groups to consider , cdefTile :: !Text -- ^ the default cave tile group name - , ccorridorTile :: !Text -- ^ the cave corridor tile group name + , cdarkCorTile :: !Text -- ^ the dark cave corridor tile group name + , clitCorTile :: !Text -- ^ the dark 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 } deriving Show -- No Eq and Ord to make extending it logically sound, see #53 +-- TODO: check many things, e.g., if all items and actors fit in the dungeon. -- | Filter a list of kinds, passing through only the incorrect ones, if any. -- -- 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 = RollDiceXY (gx, gy) - , cminPlaceSize = RollDiceXY (mx, my) +cvalidate = L.filter (\ CaveKind{ cgrid + , cminPlaceSize + , cmaxPlaceSize , .. } -> - let (maxGridX, maxGridY) = (maxDice gx, maxDice gy) - (maxPlaceSizeX, maxPlaceSizeY) = (maxDice mx, maxDice my) - xborder = if maxGridX == 1 then 5 else 3 - yborder = if maxGridX == 1 then 5 else 3 - in T.length cname <= 25 - && (maxGridX * (xborder + maxPlaceSizeX) + 1 > cxsize || - maxGridY * (yborder + maxPlaceSizeY) + 1 > cysize)) + 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 + in T.length cname > 25 + || cxsize < 7 + || cysize < 7 + || minMinSizeX < 1 + || minMinSizeY < 1 + || minMaxSizeX < maxMinSizeX + || minMaxSizeY < maxMinSizeY + || maxGridX * (maxMinSizeX + xborder) >= cxsize + || maxGridY * (maxMinSizeY + yborder) >= cysize) 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 @@ -19,8 +19,8 @@ , 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 possibly combat - , iverbProject :: !MU.Part -- ^ the verb for projecting + , 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 } 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 @@ -10,7 +10,7 @@ import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Feature import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Utils.Assert +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 @@ -45,7 +45,7 @@ , [kt] )) lt mapFov :: (TileKind -> Color) -> M.Map (Char, Bool, Color) [TileKind] mapFov f = M.fromListWith (++) $ listFov f - namesUnequal [] = assert `failure` "no TileKind content" `with` lt + 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 diff --git a/Game/LambdaHack/Frontend.hs b/Game/LambdaHack/Frontend.hs --- a/Game/LambdaHack/Frontend.hs +++ b/Game/LambdaHack/Frontend.hs @@ -6,27 +6,30 @@ -- * Derived operation , startupF -- * Connection channels - , ChanFrontend, FrontReq(..), ConnMulti(..), connMulti, loopFrontend + , ChanFrontend, FrontReq(..), ConnMulti(..), connMulti ) where import Control.Concurrent -import Control.Concurrent.STM (TQueue, atomically, newTQueueIO) +import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, writeTQueue) import qualified Control.Concurrent.STM as STM import Control.Monad import qualified Data.EnumMap.Strict as EM import Data.Maybe import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.IO as T +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 import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Random import Game.LambdaHack.Frontend.Chosen -import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Utils.LQueue +import Game.LambdaHack.Utils.Thread type ChanFrontend = TQueue K.KM @@ -42,6 +45,8 @@ -- ^ flush frames, possibly show fadeout/fadein and ask for a keypress | FrontSlides {frontClear :: ![K.KM], frontSlides :: ![SingleFrame]} -- ^ show a whole slideshow without interleaving with other clients + | FrontFinish + -- ^ exit frontend loop type ReqMap = EM.EnumMap FactionId (LQueue AcFrame) @@ -55,8 +60,18 @@ startupF :: DebugModeCli -> IO () -> IO () startupF dbg cont = (if sfrontendStd dbg then stdStartup else chosenStartup) dbg $ \fs -> do - void $ forkIO $ loopFrontend fs connMulti + let debugPrint t = when (sdbgMsgCli dbg) $ do + T.hPutStrLn stderr t + hFlush stderr + children <- newMVar [] + void $ forkChild children $ loopFrontend fs connMulti cont + debugPrint "Server shuts down" + let toF = toMulti connMulti + -- TODO: instead of this, wait for clients to send FrontFinish or timeout + atomically $ writeTQueue toF (toEnum 0 {-hack-}, FrontFinish) + waitForChildren children + debugPrint "Frontend shuts down" -- | Display a prompt, wait for any of the specified keys (for any key, -- if the list is empty). Repeat if an unexpected key received. @@ -198,7 +213,7 @@ reqMap2 <- flushFade fr1 oldFidFrame reqMap fid let displayFrs frs = case frs of - [] -> assert `failure` "null slides" `with` fid + [] -> assert `failure` "null slides" `twith` fid [x] -> do fdisplay fs False (Just x) writeKM fid K.KM {key=K.Space, modifier=K.NoModifier} @@ -211,3 +226,6 @@ return x frLast <- displayFrs frontSlides loop (Just (fid, frLast)) reqMap2 + FrontFinish -> + return () -- TODO: apply modified flushFrames to fid + -- Do not loop again. 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 @@ -19,7 +19,7 @@ import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..)) import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Key as K -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar -- | Session data maintained by the frontend. data FrontendSession = FrontendSession @@ -45,7 +45,7 @@ bg <- Color.legalBG ] nr <- C.colorPairs when (nr < L.length s) $ - C.end >> (assert `failure` "terminal has too few color pairs" `with` nr) + C.end >> (assert `failure` "terminal has too few color pairs" `twith` nr) let (ks, vs) = unzip s ws <- C.convertStyles vs let swin = C.stdScr 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 @@ -22,10 +22,10 @@ import Graphics.UI.Gtk hiding (Point) import System.Time +import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..)) import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Key as K -import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Utils.LQueue data FrameState = diff --git a/Game/LambdaHack/Server.hs b/Game/LambdaHack/Server.hs --- a/Game/LambdaHack/Server.hs +++ b/Game/LambdaHack/Server.hs @@ -32,7 +32,6 @@ GameRestartSer aid t -> gameRestartSer aid t >> return False GameExitSer aid -> gameExitSer aid >> return False GameSaveSer _ -> gameSaveSer >> return False - CfgDumpSer aid -> cfgDumpSer aid >> return False cmdSerSemTakeTime :: (MonadAtomic m, MonadServer m) => CmdSerTakeTime -> m () cmdSerSemTakeTime cmd = case cmd of @@ -61,6 +60,7 @@ , " --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" @@ -96,6 +96,8 @@ (sdebugCli debugSer) {snewGameCli = True}} parseArgs ("--stopAfter" : s : rest) = (parseArgs rest) {sstopAfter = Just $ read s} + parseArgs ("--dumpConfig" : rest) = + (parseArgs rest) {sdumpConfig = True} parseArgs ("--fovMode" : "Digital" : r : rest) | (read r :: Int) > 0 = (parseArgs rest) {sfovMode = Just $ Digital $ read r} parseArgs ("--fovMode" : mode : rest) = 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 @@ -21,6 +21,7 @@ import Control.Concurrent import Control.Concurrent.STM (TQueue, atomically) import qualified Control.Concurrent.STM as STM +import Control.DeepSeq import Control.Monad import qualified Control.Monad.State as St import qualified Data.EnumMap.Strict as EM @@ -38,11 +39,13 @@ 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 @@ -58,11 +61,9 @@ import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Frontend as Frontend import Game.LambdaHack.Server.Action.ActionClass -import qualified Game.LambdaHack.Server.Action.ConfigIO as ConfigIO import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.State -import Game.LambdaHack.Utils.Assert import Game.LambdaHack.Utils.File debugPrint :: MonadServer m => Text -> m () @@ -89,16 +90,19 @@ getPerFid fid lid = do pers <- getsServer sper let fper = fromMaybe (assert `failure` "no perception for faction" - `with` (lid, fid)) $ EM.lookup fid pers + `twith` (lid, fid)) $ EM.lookup fid pers per = fromMaybe (assert `failure` "no perception for level" - `with` (lid, fid)) $ EM.lookup lid fper + `twith` (lid, fid)) $ EM.lookup lid fper return $! per -- | Dumps the current game rules configuration to a file. -dumpCfg :: MonadServer m => FilePath -> m () -dumpCfg fn = do +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 writeTQueueAI :: MonadConnServer m => CmdClientAI -> TQueue CmdClientAI -> m () writeTQueueAI cmd fromServer = do @@ -160,7 +164,7 @@ sendUpdateUI fid cmd = do cs <- getsDict $ fst . (EM.! fid) case cs of - Nothing -> assert `failure` "no channel for faction" `with` fid + Nothing -> assert `failure` "no channel for faction" `twith` fid Just (_, conn) -> writeTQueueUI cmd $ fromServer conn @@ -168,7 +172,7 @@ sendQueryUI fid aid = do cs <- getsDict $ fst . (EM.! fid) case cs of - Nothing -> assert `failure` "no channel for faction" `with` fid + Nothing -> assert `failure` "no channel for faction" `twith` fid Just (_, conn) -> do writeTQueueUI (CmdQueryUI aid) $ fromServer conn readTQueueUI $ toServer conn @@ -177,7 +181,7 @@ sendPingUI fid = do cs <- getsDict $ fst . (EM.! fid) case cs of - Nothing -> assert `failure` "no channel for faction" `with` fid + Nothing -> assert `failure` "no channel for faction" `twith` fid Just (_, conn) -> do writeTQueueUI CmdPingUI $ fromServer conn -- debugPrint $ "UI client" <+> showT fid <+> "pinged..." @@ -185,21 +189,16 @@ -- debugPrint $ "UI client" <+> showT fid <+> "responded." assert (cmdHack == TakeTimeSer (WaitSer (toEnum (-1)))) skip --- | Create 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 -> m (Config, R.StdGen, R.StdGen) -mkConfigRules = liftIO . ConfigIO.mkConfigRules - -- | 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{configScoresFile} = do - configExists <- liftIO $ doesFileExist configScoresFile +restoreScore Config{configAppDataDir, configScoresFile} = do + let path = configAppDataDir configScoresFile + configExists <- liftIO $ doesFileExist path if not configExists then return HighScore.empty - else liftIO $ strictDecodeEOF configScoresFile + else liftIO $ strictDecodeEOF path -- | Generate a new score, register it and save. registerScore :: MonadServer m => Status -> Maybe Actor -> FactionId -> m () @@ -215,14 +214,14 @@ Just aid -> do b <- getsState $ getActorBody aid getsState $ snd . calculateTotal b - config <- getsServer sconfig + config@Config{configAppDataDir, configScoresFile} <- getsServer sconfig -- Re-read the table in case it's changed by a concurrent game. table <- restoreScore config time <- getsState stime date <- liftIO getClockTime - let saveScore (ntable, _) = - liftIO $ encodeEOF (configScoresFile config) - (ntable :: HighScore.ScoreTable) + let path = configAppDataDir configScoresFile + saveScore (ntable, _) = + liftIO $ encodeEOF path (ntable :: HighScore.ScoreTable) maybe skip saveScore $ HighScore.register table total time status date resetSessionStart :: MonadServer m => m () @@ -275,7 +274,7 @@ deduceQuits :: (MonadAtomic m, MonadServer m) => Actor -> Status -> m () deduceQuits body status@Status{stOutcome} | stOutcome `elem` [Defeated, Camping, Restart, Conquer] = - assert `failure` "no quitting to deduce" `with` (status, body) + assert `failure` "no quitting to deduce" `twith` (status, body) deduceQuits body status = do cops <- getsState scops let fid = bfid body @@ -319,7 +318,7 @@ -- version of the config can be read from the savefile. (Config{ configAppDataDir , configRulesCfgFile - , configScoresFile }, _, _) <- mkConfigRules corule + , configScoresFile }, _, _) <- mkConfigRules corule Nothing let copies = [ (configRulesCfgFile <.> ".default", configRulesCfgFile <.> ".ini") , (configScoresFile, configScoresFile) ] @@ -371,9 +370,9 @@ -- Spawn client threads. let toSpawn = newD EM.\\ oldD fdict fid = ( fst - $ fromMaybe (assert `failure` "no channel" `with` fid) + $ fromMaybe (assert `failure` "no channel" `twith` fid) $ fst - $ fromMaybe (assert `failure` "no faction" `with` fid) + $ fromMaybe (assert `failure` "no faction" `twith` fid) $ EM.lookup fid newD , maybe T.empty gname -- a faction can go inactive $ EM.lookup fid factionD @@ -419,3 +418,61 @@ 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{..} + +-- | 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) 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 @@ -7,6 +7,7 @@ ( ActionSer, executorSer ) where +import Control.Applicative import qualified Control.Monad.IO.Class as IO import Control.Monad.Trans.State.Strict hiding (State) import qualified Data.EnumMap.Strict as EM @@ -31,7 +32,7 @@ -- | Server state transformation monad. newtype ActionSer a = ActionSer {runActionSer :: StateT SerState IO a} - deriving (Monad, Functor) + deriving (Monad, Functor, Applicative) instance MonadActionRO ActionSer where getState = ActionSer $ gets serState diff --git a/Game/LambdaHack/Server/Action/ConfigIO.hs b/Game/LambdaHack/Server/Action/ConfigIO.hs deleted file mode 100644 --- a/Game/LambdaHack/Server/Action/ConfigIO.hs +++ /dev/null @@ -1,152 +0,0 @@ --- TODO: factor out parts common with Client.ConfigIO --- | Personal game configuration file support. -module Game.LambdaHack.Server.Action.ConfigIO - ( mkConfigRules, dump - ) where - -import Control.DeepSeq -import qualified Data.Char as Char -import qualified Data.ConfigFile as CF -import Data.List -import qualified Data.Text as T -import System.Directory -import System.Environment -import System.FilePath -import qualified System.Random as R - -import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Server.Config -import Game.LambdaHack.Utils.Assert - --- TODO: Refactor the client and server ConfigIO.hs, after --- https://github.com/kosmikus/LambdaHack/issues/45. - -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 $ 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 = 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" `with` (s, o) - else CP $ forceEither $ CF.set conf s o v - --- | Gets a random generator from the config or, --- if not present, generates one and updates the config with it. -getSetGen :: CP -- ^ config - -> String -- ^ name of the generator - -> IO (R.StdGen, CP) -getSetGen config option = - case getOption config "engine" option of - Just sg -> return (read sg, config) - Nothing -> do - -- Pick the randomly chosen generator from the IO monad - -- and record it in the config for debugging (can be 'D'umped). - g <- R.newStdGen - let gs = show g - c = set config "engine" option gs - return (g, c) - --- | 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 $ 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 forceEither $ CF.get conf s o - else assert `failure` "unknown CF option" `with` (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 forceEither $ CF.items conf s - else assert `failure` "unknown CF section" `with` (s, CF.to_string conf) - -parseConfigRules :: FilePath -> CP -> Config -parseConfigRules dataDir cp = - let configSelfString = let CP conf = cp in CF.to_string conf - configFirstDeathEnds = get cp "engine" "firstDeathEnds" - configFovMode = get cp "engine" "fovMode" - configSaveBkpClips = get cp "engine" "saveBkpClips" - configAppDataDir = dataDir - configScoresFile = dataDir get cp "file" "scoresFile" - configRulesCfgFile = dataDir "config.rules" - configSavePrefix = 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" `with` ident - section = getItems cp "heroName" - in map toNumber section - in Config{..} - --- | Read and parse rules config file and supplement it with random seeds. -mkConfigRules :: Kind.Ops RuleKind -> IO (Config, R.StdGen, R.StdGen) -mkConfigRules corule = do - let cpRulesDefault = rcfgRulesDefault $ Kind.stdRuleset corule - appData <- appDataDir - cpRules <- mkConfig cpRulesDefault $ appData "config.rules.ini" - (dungeonGen, cp2) <- getSetGen cpRules "dungeonRandomGenerator" - (startingGen, cp3) <- getSetGen cp2 "startingRandomGenerator" - let conf = parseConfigRules appData cp3 - -- Catch syntax errors ASAP. - !res = deepseq conf (conf, dungeonGen, startingGen) - return res 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 @@ -25,7 +25,7 @@ import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Server.Action import Game.LambdaHack.Server.State -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar storeUndo :: MonadServer m => Atomic -> m () storeUndo _atomic = @@ -133,7 +133,7 @@ PosFidAndSer fid2 -> when (fid == fid2) $ sendUpdate fid atomic PosSer -> return () PosAll -> sendUpdate fid atomic - PosNone -> assert `failure` "illegal sending" `with` (atomic, fid) + PosNone -> assert `failure` "illegal sending" `twith` (atomic, fid) mapWithKeyM_ (\fid _ -> send fid) factionD atomicRemember :: LevelId -> Perception -> State -> [CmdAtomic] 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 @@ -8,6 +8,7 @@ import qualified Data.EnumMap.Strict as EM import Data.List import Data.Maybe +import Data.Text (Text) import qualified Game.LambdaHack.Common.Effect as Effect import qualified Game.LambdaHack.Common.Feature as F @@ -21,10 +22,13 @@ import Game.LambdaHack.Content.CaveKind 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.Place -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar +import Game.LambdaHack.Utils.Frequency + convertTileMaps :: Rnd (Kind.Id TileKind) -> Int -> Int -> TileMapXY -> Rnd TileMap convertTileMaps cdefTile cxsize cysize ltile = do @@ -38,12 +42,12 @@ placeStairs cotile cmap CaveKind{..} ps = do let dist cmin l _ = all (\pos -> chessDist cxsize 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 [ dist $ cminStairDist , dist $ cminStairDist `div` 2 , dist $ cminStairDist `div` 4 , dist $ cminStairDist `div` 8 - , \p t -> Tile.hasFeature cotile F.CanActor t - && dist 0 p t -- can't overwrite stairs with other stairs ] -- | Create a level from a cave, from a cave kind. @@ -53,14 +57,18 @@ , cocave=Kind.Ops{okind=cokind} } Cave{..} ldepth minD maxD nstairUp escapeFeature = do let kc@CaveKind{..} = cokind dkind - fitArea pos = inside cxsize pos . qarea + fitArea pos = inside cxsize pos . fromArea . qarea findLegend pos = maybe clitLegendTile qlegend $ find (fitArea pos) dplaces hasEscapeAndSymbol sym t = Tile.kindHasFeature (F.Cause Effect.Escape) t && tsymbol t == sym ascendable = Tile.kindHasFeature $ F.Cause (Effect.Ascend 1) descendable = Tile.kindHasFeature $ F.Cause (Effect.Ascend (-1)) - cmap <- convertTileMaps (opick cdefTile (const True)) cxsize cysize dmap + dcond kt = not (Tile.kindHasFeature F.Clear kt) + || (if dnight then not else id) (Tile.kindHasFeature F.Lit kt) + pickDefTile = fmap (fromMaybe $ assert `failure` cdefTile) + $ opick cdefTile dcond + cmap <- convertTileMaps pickDefTile cxsize cysize dmap -- We keep two-way stairs separately, in the last component. let makeStairs :: Bool -> Bool -> Bool -> ( [(Point, Kind.Id TileKind)] @@ -79,7 +87,9 @@ stairsCur = up ++ down ++ upDown posCur = nub $ sort $ map fst stairsCur spos <- placeStairs cotile cmap kc posCur - stairId <- opick (findLegend spos) cond + let legend = findLegend spos + stairId <- fmap (fromMaybe $ assert `failure` legend) + $ opick legend cond let st = (spos, stairId) asc = ascendable $ okind stairId desc = descendable $ okind stairId @@ -110,10 +120,14 @@ escape <- case escapeFeature of Nothing -> return [] Just True -> do - upEscape <- opick (findLegend epos) $ hasEscapeAndSymbol '<' + let legend = findLegend epos + upEscape <- fmap (fromMaybe $ assert `failure` legend) + $ opick legend $ hasEscapeAndSymbol '<' return [(epos, upEscape)] Just False -> do - downEscape <- opick (findLegend epos) $ hasEscapeAndSymbol '>' + let legend = findLegend epos + downEscape <- fmap (fromMaybe $ assert `failure` legend) + $ opick legend $ hasEscapeAndSymbol '>' return [(epos, downEscape)] let exits = stairsTotal ++ escape ltile = cmap Kind.// exits @@ -122,15 +136,18 @@ , map fst $ stairsUpDown ++ stairsDown ) -- traceShow (ldepth, nstairUp, (stairsUp, stairsDown, stairsUpDown)) skip litemNum <- castDice citemNum + let itemFreq = toFreq cname citemFreq + assert (not $ nullFreq itemFreq) skip lsecret <- random - return $! levelFromCaveKind cops kc ldepth ltile lstair litemNum lsecret + return $! levelFromCaveKind cops kc ldepth ltile lstair + litemNum itemFreq lsecret levelFromCaveKind :: Kind.COps -> CaveKind -> Int -> TileMap -> ([Point], [Point]) - -> Int -> Int + -> Int -> Frequency Text -> Int -> Level levelFromCaveKind Kind.COps{cotile} - CaveKind{..} ldepth ltile lstair litemNum lsecret = + CaveKind{..} ldepth ltile lstair litemNum litemFreq lsecret = Level { ldepth , lprio = EM.empty @@ -147,6 +164,7 @@ in Kind.foldlArray f 0 ltile , ltime = timeTurn , litemNum + , litemFreq , lsecret , lhidden = chidden } @@ -158,7 +176,8 @@ let Kind.COps{cocave=Kind.Ops{opick}} = cops (genName, escapeFeature) = fromMaybe ("dng", Nothing) $ EM.lookup ldepth caves - ci <- opick genName (const True) + ci <- fmap (fromMaybe $ assert `failure` genName) + $ opick genName (const True) cave <- buildCave cops (fromEnum ldepth) totalDepth ci buildLevel cops cave (fromEnum ldepth) (fromEnum minD) (fromEnum maxD) nstairUp @@ -176,7 +195,7 @@ let (minD, maxD) = case (EM.minViewWithKey caves, EM.maxViewWithKey caves) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) - _ -> assert `failure` "no caves" `with` caves + _ -> assert `failure` "no caves" `twith` caves totalDepth = if minD == maxD then 10 else fromEnum maxD - fromEnum minD + 1 diff --git a/Game/LambdaHack/Server/DungeonGen/Area.hs b/Game/LambdaHack/Server/DungeonGen/Area.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Server/DungeonGen/Area.hs @@ -0,0 +1,53 @@ +-- | Rectangular areas of levels and their basic operations. +module Game.LambdaHack.Server.DungeonGen.Area + ( Area, toArea, fromArea, trivialArea, grid, shrink + ) where + +import Data.Binary + +import Game.LambdaHack.Common.PointXY + +-- | The type of areas. The bottom left and the top right points. +data Area = Area !X !Y !X !Y + deriving Show + +-- | Checks if it's an area with at least one field. +toArea :: (X, Y, X, Y) -> Maybe Area +toArea (x0, y0, x1, y1) = if x0 <= x1 && y0 <= y1 + then Just $ Area x0 y0 x1 y1 + else Nothing + +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 + +-- | Divide uniformly a larger area into the given number of smaller areas +-- overlapping at the edges. +grid :: (X, Y) -> Area -> [(PointXY, 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)) + | x <- [0..nx-1], y <- [0..ny-1] ] + +-- | Enlarge (or shrink) the given area on all fours sides by the amount. +shrink :: Area -> Maybe Area +shrink (Area x0 y0 x1 y1) = toArea (x0 + 1, y0 + 1, x1 - 1, y1 - 1) + +instance Binary Area where + put (Area x0 y0 x1 y1) = do + put x0 + put y0 + put x1 + put y1 + get = do + x0 <- get + y0 <- get + x1 <- get + y1 <- get + return (Area x0 y0 x1 y1) 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 @@ -9,40 +9,53 @@ ) where import qualified Data.EnumSet as ES +import Data.Maybe -import Game.LambdaHack.Common.Area import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.Random -import Game.LambdaHack.Utils.Assert +import Game.LambdaHack.Common.VectorXY +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 (x0, y0, x1, y1) = do +xyInArea area = do + let (x0, y0, x1, y1) = fromArea area rx <- randomR (x0, x1) ry <- randomR (y0, y1) return $ PointXY (rx, ry) -- | Create a random room according to given parameters. mkRoom :: (X, Y) -- ^ minimum size + -> (X, Y) -- ^ maximum size -> Area -- ^ the containing area, not the room itself -> Rnd Area -mkRoom (xm, ym) (x0, y0, x1, y1) = do - let area0 = (x0, y0, x1 - xm + 1, y1 - ym + 1) - assert (validArea area0 `blame` area0) $ do - PointXY (rx0, ry0) <- xyInArea area0 - let area1 = (rx0 + xm - 1, ry0 + ym - 1, x1, y1) - assert (validArea area1 `blame` area1) $ do - PointXY (rx1, ry1) <- xyInArea area1 - return (rx0, ry0, rx1, ry1) +mkRoom (xm, ym) (xM, yM) area = do + let (x0, y0, x1, y1) = fromArea area + 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 + 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 + let a3 = (rx0, ry0, rx1, ry1) + area3 = fromMaybe (assert `failure` a3) $ toArea a3 + return area3 --- | Create a void room, i.e., a single point area. -mkVoidRoom :: Area -- ^ the area in which to pick the point - -> Rnd Area -mkVoidRoom area = assert (validArea area `blame` area) $ do - PointXY (ry, rx) <- xyInArea area - return (ry, rx, ry, rx) +-- | Create a void room, i.e., a single point area within the designated area. +mkVoidRoom :: Area -> Rnd Area +mkVoidRoom area = do + -- Pass corridors closer to the middle of the grid area, if possible. + let core = fromMaybe area $ shrink area + pxy <- xyInArea core + return $ trivialArea pxy -- Choosing connections between areas in a grid @@ -83,7 +96,7 @@ randomConnection :: (X, Y) -> Rnd (PointXY, PointXY) randomConnection (nx, ny) = assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` "wrong connection" - `with` (nx, ny)) $ do + `twith` (nx, ny)) $ do rb <- oneOf [False, True] if rb || ny <= 1 then do @@ -116,35 +129,55 @@ Horiz -> return $ map PointXY [(x0, y0), (rx, y0), (rx, y1), (x1, y1)] Vert -> return $ map PointXY [(x0, y0), (x0, ry), (x1, ry), (x1, y1)] --- TODO: assert that sx1 <= tx0, etc. --- | Try to connect two places with a corridor. +-- | 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 -- is big enough. Note that with @pfence == FNone@, the area considered --- is the interior of the place, without the outermost tiles. -connectPlaces :: Area -> Area -> Rnd Corridor -connectPlaces sa@(_, _, sx1, sy1) ta@(tx0, ty0, _, _) = do - let trim (x0, y0, x1, y1) = - let trim4 (v0, v1) | v1 - v0 < 6 = (v0, v1) +-- is the strict interior of the place, without the outermost tiles. +connectPlaces :: (Area, Area) -> (Area, Area) -> Rnd Corridor +connectPlaces (sa, so) (ta, to) = do + let (_, _, sx1, sy1) = fromArea sa + (_, _, sox1, soy1) = fromArea so + (tx0, ty0, _, _) = fromArea ta + (tox0, toy0, _, _) = fromArea to + assert (sx1 <= tx0 || sy1 <= ty0 `blame` (sa, ta)) skip + assert (sx1 <= sox1 || sy1 <= soy1 `blame` (sa, so)) skip + assert (tx0 >= tox0 || ty0 >= toy0 `blame` (ta, to)) skip + let trim area = + let (x0, y0, x1, y1) = fromArea area + trim4 (v0, v1) | v1 - v0 < 6 = (v0, v1) | v1 - v0 < 8 = (v0 + 3, v1 - 3) | otherwise = (v0 + 4, v1 - 4) (nx0, nx1) = trim4 (x0, x1) (ny0, ny1) = trim4 (y0, y1) - in (nx0, ny0, nx1, ny1) - PointXY (sx, sy) <- xyInArea $ trim sa - PointXY (tx, ty) <- xyInArea $ trim ta - let xarea = (sx1+2, min sy ty, tx0-2, max sy ty) - yarea = (sx, sy1+2, tx, ty0-2) - xyarea = (sx1+2, sy1+2, tx0-2, ty0-2) - (hv, area) <- if validArea xyarea - then fmap (\ hv -> (hv, xyarea)) (oneOf [Horiz, Vert]) - else if validArea xarea - then return (Horiz, xarea) - else return (Vert, normalizeArea yarea) -- vertical bias + in fromMaybe (assert `failure` area) $ toArea (nx0, ny0, nx1, ny1) + PointXY (sx, sy) <- xyInArea $ trim so + PointXY (tx, ty) <- xyInArea $ trim to + let hva sarea tarea = do + let (_, _, zsx1, zsy1) = fromArea sarea + (ztx0, zty0, _, _) = fromArea tarea + xa = (zsx1+2, min sy ty, ztx0-2, max sy ty) + ya = (min sx tx, zsy1+2, max sx tx, zty0-2) + xya = (zsx1+2, zsy1+2, ztx0-2, zty0-2) + case toArea xya of + Just xyarea -> fmap (\hv -> (hv, Just xyarea)) (oneOf [Horiz, Vert]) + Nothing -> + case toArea xa of + Just xarea -> return (Horiz, Just xarea) + Nothing -> return (Vert, toArea ya) -- Vertical bias. + (hvOuter, areaOuter) <- hva so to + (hv, area) <- case areaOuter of + Just arenaOuter -> return (hvOuter, arenaOuter) + Nothing -> do + -- TODO: let mkCorridor only pick points on the floor fence + (hvInner, aInner) <- hva sa ta + let yell = assert `failure` (sa, so, ta, to, areaOuter, aInner) + areaInner = fromMaybe yell aInner + return (hvInner, areaInner) + -- 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 (if trivialArea sa then sx else sx1 + 1, sy), - PointXY (if trivialArea ta then tx else tx0 - 1, ty)) - Vert -> (PointXY (sx, if trivialArea sa then sy else sy1 + 1), - PointXY (tx, if trivialArea ta then ty else ty0 - 1)) + Horiz -> (PointXY (sox1, sy), PointXY (tox0, ty)) + Vert -> (PointXY (sx, soy1), PointXY (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 @@ -3,23 +3,26 @@ ( TileMapXY, ItemFloorXY, Cave(..), buildCave ) where +import Control.Arrow ((&&&)) import Control.Monad import qualified Data.EnumMap.Strict as EM import qualified Data.List as L +import Data.Maybe -import Game.LambdaHack.Common.Area 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.Misc import Game.LambdaHack.Common.PointXY import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Content.CaveKind +import Game.LambdaHack.Content.PlaceKind 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 @@ -36,6 +39,7 @@ , dmap :: !TileMapXY -- ^ tile kinds in the cave , ditem :: !ItemFloorXY -- ^ starting items in the cave , dplaces :: ![Place] -- ^ places generated in the cave + , dnight :: !Bool -- ^ whether the cave is dark } deriving Show @@ -70,43 +74,74 @@ -> Rnd Cave buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{ opick , ouniqGroup } - , cocave=Kind.Ops{okind} } + , cocave=Kind.Ops{okind} + , coplace=Kind.Ops{okind=pokind} } ln depth ci = do let kc@CaveKind{..} = okind ci lgrid@(gx, gy) <- castDiceXY cgrid - lminplace <- castDiceXY cminPlaceSize - let gs = grid lgrid (0, 0, cxsize - 1, cysize - 1) - mandatory1 <- replicateM (cnonVoidMin `div` 2) $ - xyInArea (0, 0, gx `div` 3, gy - 1) - mandatory2 <- replicateM (cnonVoidMin `divUp` 2) $ - xyInArea (gx - 1 - (gx `div` 3), 0, gx - 1, gy - 1) + -- 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. + 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 + | otherwise = fullArea + gs = grid lgrid area + (addedConnects, voidPlaces) <- do + if gx * gy > 1 then do + let fractionOfPlaces r = round $ r * fromIntegral (gx * gy) + cauxNum = fractionOfPlaces cauxConnects + addedC <- replicateM cauxNum (randomConnection lgrid) + let gridArea = fromMaybe (assert `failure` lgrid) + $ toArea (0, 0, gx - 1, gy - 1) + voidNum = fractionOfPlaces cmaxVoid + voidPl <- replicateM voidNum $ xyInArea gridArea -- repetitions are OK + return (addedC, voidPl) + else return ([], []) + minPlaceSize <- castDiceXY cminPlaceSize + maxPlaceSize <- castDiceXY cmaxPlaceSize places0 <- mapM (\ (i, r) -> do - rv <- chance cvoidChance - r' <- if rv && i `notElem` (mandatory1 ++ mandatory2) - then mkVoidRoom r - else mkRoom lminplace r + -- Reserved for corridors and the global fence. + let innerArea = fromMaybe (assert `failure` (i, r)) + $ shrink r + r' <- if i `elem` voidPlaces + then fmap Left $ mkVoidRoom innerArea + else fmap Right $ mkRoom minPlaceSize + maxPlaceSize innerArea return (i, r')) gs + let hardRockId = ouniqGroup "outer fence" + fence = buildFence hardRockId subFullArea + dnight <- chanceDeep ln depth cnightChance + darkCorTile <- fmap (fromMaybe $ assert `failure` cdarkCorTile) + $ opick cdarkCorTile (const True) + litCorTile <- fmap (fromMaybe $ assert `failure` clitCorTile) + $ opick clitCorTile (const True) + 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 + return (EM.union tmap m, place : pls, (i, Right (r, place)) : qls) + (lplaces, dplaces, qplaces0) <- foldM addPl (fence, [], []) places0 connects <- connectGrid lgrid - addedConnects <- - if gx * gy > 1 - then let caux = round $ cauxConnects * fromIntegral (gx * gy) - in replicateM caux (randomConnection lgrid) - else return [] let allConnects = L.union connects addedConnects -- no duplicates - places = EM.fromList places0 - cs <- mapM (\ (p0, p1) -> do - let r0 = places EM.! p0 - r1 = places EM.! p1 - connectPlaces r0 r1) allConnects - let hardRockId = ouniqGroup "hard rock" - fenceBounds = (1, 1, cxsize - 2, cysize - 2) - fence = buildFence hardRockId fenceBounds - pickedCorTile <- opick ccorridorTile (const True) - let addPl (m, pls) (_, (x0, _, x1, _)) | x0 == x1 = return (m, pls) - addPl (m, pls) (_, r) = do - (tmap, place) <- buildPlace cops kc pickedCorTile ln depth r - return (EM.union tmap m, place : pls) - (lplaces, dplaces) <- foldM addPl (fence, []) places0 + qplaces = EM.fromList qplaces0 + cs <- mapM (\(p0, p1) -> do + let shrinkPlace (r, Place{qkind}) = + case shrink r of + Nothing -> (r, r) -- FNone place of x and/or y size 1 + Just sr -> case pfence $ pokind qkind of + FFloor -> + -- Avoid corridors touching the floor fence, + -- but let them merge with the fence. + case shrink sr of + Nothing -> (sr, r) + Just mergeArea -> (mergeArea, r) + _ -> (sr, sr) + shrinkForFence = either (id &&& id) shrinkPlace + rr0 = shrinkForFence $ qplaces EM.! p0 + rr1 = shrinkForFence $ qplaces EM.! p1 + connectPlaces rr0 rr1) allConnects let lcorridors = EM.unions (L.map (digCorridors pickedCorTile) cs) lm = EM.unionWith (mergeCorridor cotile) lcorridors lplaces -- Convert wall openings into doors, possibly. @@ -133,6 +168,7 @@ , ditem = EM.empty , dmap , dplaces + , dnight } return cave 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,17 +1,17 @@ {-# LANGUAGE RankNTypes #-} -- | Generation of places from place kinds. module Game.LambdaHack.Server.DungeonGen.Place - ( TileMapXY, Place(..), placeValid, buildFence, buildPlace + ( TileMapXY, Place(..), placeCheck, buildFence, buildPlace ) where 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 Game.LambdaHack.Common.Area import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.PointXY @@ -19,7 +19,8 @@ import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.TileKind -import Game.LambdaHack.Utils.Assert +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 @@ -34,23 +35,6 @@ } deriving Show -instance Binary Place where - put Place{..} = do - put qkind - put qarea - put qseen - put qlegend - put qsolidFence - put qhollowFence - get = do - qkind <- get - qarea <- get - qseen <- get - qlegend <- get - qsolidFence <- get - qhollowFence <- get - return Place{..} - -- | 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@. @@ -61,51 +45,62 @@ -- overlap between consecutive coners and no trimming. -- For other tiling methods, check that the area is large enough for tiling -- the corner twice in each direction, with a possible one row/column overlap. -placeValid :: Area -- ^ the area to fill +placeCheck :: Area -- ^ the area to fill -> PlaceKind -- ^ the place kind to construct -> Bool -placeValid r PlaceKind{..} = - let (x0, y0, x1, y1) = expandFence pfence r - dx = x1 - x0 + 1 - dy = y1 - y0 + 1 - dxcorner = case ptopLeft of [] -> 0 ; l : _ -> T.length l - dycorner = L.length ptopLeft - wholeOverlapped d dcorner = d > 1 && dcorner > 1 && - (d - 1) `mod` (2 * (dcorner - 1)) == 0 - in case pcover of - CAlternate -> wholeOverlapped dx dxcorner && - wholeOverlapped dy dycorner - _ -> dx >= 2 * dxcorner - 1 && - dy >= 2 * dycorner - 1 +placeCheck r PlaceKind{..} = + case interiorArea pfence r of + Nothing -> False + Just area -> + let (x0, y0, x1, y1) = fromArea area + dx = x1 - x0 + 1 + dy = y1 - y0 + 1 + dxcorner = case ptopLeft of [] -> 0 ; l : _ -> T.length l + dycorner = L.length ptopLeft + wholeOverlapped d dcorner = d > 1 && dcorner > 1 && + (d - 1) `mod` (2 * (dcorner - 1)) == 0 + in case pcover of + CAlternate -> wholeOverlapped dx dxcorner && + wholeOverlapped dy dycorner + _ -> dx >= 2 * dxcorner - 1 && + dy >= 2 * dycorner - 1 --- | Modify available room area according to fence type. -expandFence :: Fence -> Area -> Area -expandFence fence r = case fence of - FWall -> r - FFloor -> expand r (-1) - FNone -> expand r 1 +-- | Calculate interior room area according to fence type, based on the +-- total area for the room and it's fence. This is used for checking +-- if the room fits in the area, for digging up the place and the fence +-- and for deciding if the room is dark or lit later in the dungeon +-- generation process (e.g., for stairs). +interiorArea :: Fence -> Area -> Maybe Area +interiorArea fence r = case fence of + FWall -> shrink r + FFloor -> shrink r + FNone -> Just r -- | Given a few parameters, roll and construct a 'Place' datastructure -- and fill a cave section acccording to it. buildPlace :: Kind.COps -- ^ the game content -> CaveKind -- ^ current cave kind - -> Kind.Id TileKind -- ^ fence tile, if fence hollow + -> 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 -- ^ interior area of the place + -> Area -- ^ whole area of the place, fence included -> Rnd (TileMapXY, Place) buildPlace Kind.COps{ cotile=cotile@Kind.Ops{opick=opick} , coplace=Kind.Ops{okind=pokind, opick=popick} } - CaveKind{..} qhollowFence ln depth r - = assert (not (trivialArea r) `blame` r) $ do - qsolidFence <- opick cfillerTile (const True) + CaveKind{..} darkCorTile litCorTile ln depth r = do + qsolidFence <- fmap (fromMaybe $ assert `failure` cfillerTile) + $ opick cfillerTile (const True) dark <- chanceDeep ln depth cdarkChance - qkind <- popick "rogue" (placeValid r) - let kr = pokind qkind + let cave = "rogue" + qkind <- fmap (fromMaybe $ assert `failure` (cave, r)) + $ popick cave (placeCheck r) + let qhollowFence = if dark then darkCorTile else litCorTile + kr = pokind qkind qlegend = if dark then cdarkLegendTile else clitLegendTile qseen = False - qarea = expandFence (pfence kr) r - place = assert (validArea qarea `blame` qarea) Place {..} + qarea = fromMaybe (assert `failure` (kr, r)) $ interiorArea (pfence kr) r + place = Place {..} legend <- olegend cotile qlegend let xlegend = EM.insert 'X' qhollowFence legend return (digPlace place kr xlegend, place) @@ -120,18 +115,20 @@ symbols = ofoldrWithKey getSymbols ES.empty getLegend s acc = do m <- acc - tk <- opick group $ (== s) . tsymbol + tk <- fmap (fromMaybe $ assert `failure` (group, s)) + $ opick group $ (== s) . tsymbol return $ EM.insert s tk m - legend = ES.fold getLegend (return EM.empty) symbols + 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 fenceId (x0, y0, x1, y1) = - EM.fromList $ [ (PointXY (x, y), fenceId) - | x <- [x0-1, x1+1], y <- [y0..y1] ] ++ - [ (PointXY (x, y), fenceId) - | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ] +buildFence fenceId area = + let (x0, y0, x1, y1) = fromArea area + in EM.fromList $ [ (PointXY (x, y), fenceId) + | x <- [x0-1, x1+1], y <- [y0..y1] ] ++ + [ (PointXY (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 @@ -150,9 +147,15 @@ tilePlace :: Area -- ^ the area to fill -> PlaceKind -- ^ the place kind to construct -> EM.EnumMap PointXY Char -tilePlace (x0, y0, x1, y1) pl@PlaceKind{..} = - let dx = x1 - x0 + 1 - dy = y1 - y0 + 1 +tilePlace area pl@PlaceKind{..} = + let (x0, y0, x1, y1) = fromArea area + xwidth = x1 - x0 + 1 + ywidth = y1 - y0 + 1 + dxcorner = case ptopLeft of + [] -> 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)] fillInterior f = @@ -167,13 +170,13 @@ interior = case pcover of CAlternate -> let tile :: Int -> [a] -> [a] - tile _ [] = assert `failure` "nothing to tile" `with` pl + tile _ [] = assert `failure` "nothing to tile" `twith` pl tile d pat = L.take d (L.cycle $ L.init pat ++ L.init (L.reverse pat)) in fillInterior tile CStretch -> let stretch :: Int -> [a] -> [a] - stretch _ [] = assert `failure` "nothing to streth" `with` pl + stretch _ [] = assert `failure` "nothing to stretch" `twith` pl stretch d pat = tileReflect d (pat ++ L.repeat (L.last pat)) in fillInterior stretch CReflect -> @@ -181,3 +184,20 @@ reflect d pat = tileReflect d (L.cycle pat) in fillInterior reflect in EM.fromList interior + +instance Binary Place where + put Place{..} = do + put qkind + put qarea + put qseen + put qlegend + put qsolidFence + put qhollowFence + get = do + qkind <- get + qarea <- get + qseen <- get + qlegend <- get + qsolidFence <- get + qhollowFence <- get + 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,7 +4,7 @@ ( -- + Semantics of effects itemEffect, effectSem -- * Assorted operations - , createItems, addHero, spawnMonsters, electLeader, deduceKilled + , createItems, addHero, spawnMonsters, pickFaction, electLeader, deduceKilled ) where import Control.Monad @@ -39,7 +39,7 @@ import Game.LambdaHack.Server.Action import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.State -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar import Game.LambdaHack.Utils.Frequency -- + Semantics of effects @@ -144,7 +144,7 @@ fact <- getsState $ (EM.! bfid tb) . sfactionD lb <- getsState $ actorNotProjList (isAtWar fact) lid let nEnemy = length lb - if nEnemy == 0 then do + if nEnemy == 0 || bproj tb then do execSfxAtomic $ EffectD target Effect.NoEffect return False else do @@ -158,7 +158,7 @@ effectDominate source target = do sb <- getsState (getActorBody source) tb <- getsState (getActorBody target) - if bfid tb == bfid sb then do + if bfid tb == bfid sb || bproj tb then do -- TODO: drop the projectile? execSfxAtomic $ EffectD target Effect.NoEffect return False else do @@ -222,12 +222,14 @@ -> m () summonFriends bfid ps lid = do Kind.COps{ coactor=coactor@Kind.Ops{opick} - , cofact=Kind.Ops{okind} } <- getsState scops + , cofaction=Kind.Ops{okind} } <- getsState scops time <- getsState $ getLocalTime lid factionD <- getsState sfactionD let fact = okind $ gkind $ factionD EM.! bfid - forM_ ps $ \ p -> do - mk <- rndToAction $ opick (fname fact) (const True) + forM_ ps $ \p -> do + let summonName = fname fact + mk <- rndToAction $ fmap (fromMaybe $ assert `failure` summonName) + $ opick summonName (const True) if mk == heroKindId coactor then addHero bfid p lid [] Nothing time else addMonster mk bfid p lid time @@ -280,34 +282,45 @@ tm <- getsState (getActorBody target) ps <- getsState $ nearbyFreePoints cotile (const True) (bpos tm) (blid tm) time <- getsState $ getLocalTime (blid tm) - spawnMonsters (take power ps) (blid tm) (const True) time "summon" - return True + mfid <- pickFaction "summon" (const True) + case mfid of + Nothing -> return False -- no faction summons + Just fid -> do + 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. spawnMonsters :: (MonadAtomic m, MonadServer m) - => [Point] -> LevelId -> ((FactionId, Faction) -> Bool) - -> Time -> Text + => [Point] -> LevelId -> Time -> FactionId -> m () -spawnMonsters ps lid filt time freqChoice = assert (not $ null ps) $ do - Kind.COps{ coactor=Kind.Ops{opick} - , cofact=Kind.Ops{okind} } <- getsState scops +spawnMonsters ps lid time fid = assert (not $ null ps) $ do + Kind.COps{coactor=Kind.Ops{opick}, cofaction=Kind.Ops{okind}} <- getsState scops + fact <- getsState $ (EM.! fid) . sfactionD + let spawnName = fname $ okind $ gkind fact + laid <- forM ps $ \ p -> do + mk <- rndToAction $ fmap (fromMaybe $ assert `failure` spawnName) + $ opick spawnName (const True) + addMonster mk fid p lid time + mleader <- getsState $ gleader . (EM.! fid) . sfactionD -- just changed + when (isNothing mleader) $ + execCmdAtomic $ LeadFactionA fid Nothing (Just $ head laid) + +-- | Roll a faction based on faction kind frequency key. +pickFaction :: MonadServer m + => Text + -> ((FactionId, Faction) -> Bool) + -> m (Maybe FactionId) +pickFaction freqChoice ffilter = do + Kind.COps{cofaction=Kind.Ops{okind}} <- getsState scops factionD <- getsState sfactionD - -- TODO: rewrite with opick? let f (fid, fact) = let kind = okind (gkind fact) - g n = (n, (kind, fid)) + g n = (n, fid) in fmap g $ lookup freqChoice $ ffreq kind - case mapMaybe f $ filter filt $ EM.assocs factionD of - [] -> return () -- no faction spawns - spawnList -> do - let freq = toFreq "spawnMonsters" spawnList - (spawnKind, bfid) <- rndToAction $ frequency freq - laid <- forM ps $ \ p -> do - mk <- rndToAction $ opick (fname spawnKind) (const True) - addMonster mk bfid p lid time - mleader <- getsState $ gleader . (EM.! bfid) . sfactionD - when (isNothing mleader) $ - execCmdAtomic $ LeadFactionA bfid Nothing (Just $ head laid) + flist = mapMaybe f $ filter ffilter $ EM.assocs factionD + freq = toFreq ("pickFaction" <+> freqChoice) flist + if nullFreq freq then return Nothing + else fmap Just $ rndToAction $ frequency freq -- | Create a new monster on the level, at a given position -- and with a given actor kind and HP. @@ -336,10 +349,11 @@ Kind.COps{coitem} <- getsState scops flavour <- getsServer sflavour discoRev <- getsServer sdiscoRev - Level{ldepth} <- getLevel lid + Level{ldepth, litemFreq} <- getLevel lid depth <- getsState sdepth replicateM_ n $ do - (item, k, _) <- rndToAction $ newItem coitem flavour discoRev ldepth depth + (item, k, _) <- rndToAction + $ newItem coitem flavour discoRev litemFreq ldepth depth itemRev <- getsServer sitemRev case HM.lookup item itemRev of Just iid -> @@ -349,7 +363,7 @@ icounter <- getsServer sicounter modifyServer $ \ser -> ser { sicounter = succ icounter - , sitemRev = HM.insert item icounter (sitemRev ser)} + , sitemRev = HM.insert item icounter (sitemRev ser) } execCmdAtomic $ CreateItemA icounter item k (CFloor lid pos) -- ** ApplyPerfume @@ -395,7 +409,8 @@ let lid1 = blid b1 pos1 = bpos b1 (lid2, pos2) <- getsState $ whereTo lid1 pos1 k - if lid2 == lid1 && pos2 == pos1 then return False + if lid2 == lid1 && pos2 == pos1 || bproj b1 then + return False else do -- The actor is added to the new level, but there can be other actors -- at his new position. @@ -445,7 +460,7 @@ switchLevels2 aid bOld ais lidNew posNew = do let lidOld = blid bOld side = bfid bOld - assert (lidNew /= lidOld `blame` "stairs looped" `with` lidNew) skip + assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) skip -- Sync the actor time with the level time. timeOld <- getsState $ getLocalTime lidOld timeLastVisited <- getsState $ getLocalTime lidNew @@ -480,7 +495,7 @@ let fid = bfid b spawn <- getsState $ isSpawnFaction fid summon <- getsState $ isSummonFaction fid - if spawn || summon then return False + if spawn || summon || bproj b then return False else do deduceQuits b $ Status Escape (fromEnum $ blid b) "" return True 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 @@ -7,7 +7,7 @@ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Server.Fov.Common -import Game.LambdaHack.Utils.Assert +import Control.Exception.Assert.Sugar -- | Calculates the list of tiles, in @Bump@ coordinates, visible from (0, 0), -- within the given sight range. 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 @@ -9,7 +9,7 @@ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Server.Fov.Common -import Game.LambdaHack.Utils.Assert +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. 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 @@ -7,7 +7,7 @@ import Data.Ratio import Game.LambdaHack.Server.Fov.Common -import Game.LambdaHack.Utils.Assert +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 @@ -11,6 +11,7 @@ import Data.Maybe import qualified Data.Ord as Ord +import Control.Exception.Assert.Sugar import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Action import Game.LambdaHack.Common.Actor @@ -40,7 +41,6 @@ import Game.LambdaHack.Server.ServerSem import Game.LambdaHack.Server.StartAction import Game.LambdaHack.Server.State -import Game.LambdaHack.Utils.Assert -- | Start a game session. Loop, communicating with clients. loopSer :: (MonadAtomic m, MonadConnServer m) @@ -75,7 +75,10 @@ initPer _ -> do -- Starting a new game. -- Set up commandline debug mode - s <- gameReset cops sdebug + 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} let speedup = speedupCOps (sallClear sdebugNxt) @@ -83,6 +86,7 @@ updateConn executorUI executorAI initPer reinitGame + when (sdumpConfig sdebug) $ void $ dumpCfg resetSessionStart -- Start a clip (a part of a turn for which one or more frames -- will be generated). Do whatever has to be done @@ -188,7 +192,7 @@ -> LevelId -> m () handleActors cmdSerSem lid = do - Kind.COps{cofact=Kind.Ops{okind}} <- getsState scops + 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 @@ -234,20 +238,23 @@ switchLeader cmdS = do -- TODO: check that the command is legal first, report and reject, -- but do not crash (currently server asserts things and crashes) - let leaderNew = aidCmdSer cmdS - leadAtoms = - if leaderNew /= aid - then -- Only leader can change leaders - -- TODO: effLvlGoUp changes - assert (mleader == Just aid) - [LeadFactionA side mleader (Just leaderNew)] + let aidNew = aidCmdSer cmdS + bPre <- getsState $ getActorBody aidNew + let leadAtoms = + if aidNew /= aid -- switched, so aid must be leader + 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)) + [LeadFactionA side mleader (Just aidNew)] else [] mapM_ execCmdAtomic leadAtoms - bPre <- getsState $ getActorBody leaderNew assert (bfid bPre == side `blame` "client tries to move other faction actors" - `with` (bPre, side)) skip - return (leaderNew, bPre) + `twith` (bPre, side)) skip + return (aidNew, bPre) extraFrames bPre = do -- Generate extra frames if the actor has already moved during -- this clip, so his multiple moves would be collapsed @@ -261,7 +268,7 @@ if queryUI then do -- The client always displays a frame in this case. cmdS <- sendQueryUI side aid - (leaderNew, bPre) <- switchLeader cmdS + (aidNew, bPre) <- switchLeader cmdS timed <- if bhp bPre <= 0 && not (bproj bPre) then do execSfxAtomic @@ -276,7 +283,7 @@ -- RET waits .3s and gives back control, -- Any other key does the .3s wait and the action from the key -- at once. - when timed $ advanceTime leaderNew + when timed $ advanceTime aidNew extraFrames bPre else do -- Order the UI client (if any) corresponding to the AI client @@ -296,13 +303,13 @@ when canMove $ execSfxAtomic $ RecordHistoryD side cmdT <- sendQueryAI side aid let cmdS = TakeTimeSer cmdT - (leaderNew, bPre) <- switchLeader cmdS + (aidNew, bPre) <- switchLeader cmdS assert (not (bhp bPre <= 0 && not (bproj bPre)) `blame` "AI switches to an incapacitated actor" - `with` (cmdS, bPre, side)) skip + `twith` (cmdS, bPre, side)) skip void $ cmdSerSem cmdS -- AI always takes time and so doesn't loop. - advanceTime leaderNew + advanceTime aidNew extraFrames bPre handleActors cmdSerSem lid @@ -346,21 +353,30 @@ depth <- getsState sdepth rc <- rndToAction $ monsterGenChance ldepth depth (length spawns) when rc $ do - let allPers = ES.unions $ map (totalVisible . (EM.! lid)) $ EM.elems pers - pos <- rndToAction $ rollSpawnPos cops allPers lid lvl s time <- getsState $ getLocalTime lid - spawnMonsters [pos] lid (const True) time "spawn" + mfid <- pickFaction "spawn" (const True) + case mfid of + Nothing -> return () -- no faction spawns + Just fid -> do + let allPers = ES.unions $ map (totalVisible . (EM.! lid)) + $ EM.elems $ EM.delete fid pers -- expensive :( + pos <- rndToAction $ rollSpawnPos cops allPers lid lvl fid s + spawnMonsters [pos] lid time fid -rollSpawnPos :: Kind.COps -> ES.EnumSet Point -> LevelId -> Level -> State +rollSpawnPos :: Kind.COps -> ES.EnumSet Point + -> LevelId -> Level -> FactionId -> State -> Rnd Point -rollSpawnPos Kind.COps{cotile} visible lid Level{ltile, lxsize, lysize} s = do +rollSpawnPos Kind.COps{cotile} visible + lid Level{ltile, lxsize, lysize} fid s = do let factionDist = max lxsize lysize - 5 - inhabitants = actorNotProjList (const True) lid s + inhabitants = actorNotProjList (/= fid) lid s as = actorList (const True) lid s isLit = Tile.isLit cotile distantAtLeast d p _ = all (\b -> chessDist lxsize (bpos b) p > d) inhabitants findPosTry 40 ltile + ( \p t -> Tile.hasFeature cotile F.Walkable t + && unoccupied as p) [ \_ t -> not (isLit t) -- no such tiles on some maps , distantAtLeast factionDist , distantAtLeast $ factionDist `div` 2 @@ -369,8 +385,6 @@ , \_ t -> Tile.hasFeature cotile F.CanActor t -- in reachable area , distantAtLeast $ factionDist `div` 4 , distantAtLeast 3 -- otherwise a fast actor can walk and hit in one turn - , \p t -> Tile.hasFeature cotile F.Walkable t - && unoccupied as p ] -- TODO: generalize to any list of items (or effects) applied to all actors @@ -438,15 +452,18 @@ $ QuitFactionA fid Nothing (gquit fact) Nothing) campers saveAndExit -- Don't call @loopServer@, that is, quit the game loop. + -- debugPrint "Server loop finished" saveAndExit :: (MonadAtomic m, MonadConnServer m) => m () saveAndExit = do cops <- getsState scops -- Save client and server data. saveBkpAll + -- debugPrint "Server saves game before exit" -- Kill all clients, including those that did not take part -- in the current game. -- Clients exit not now, but after they print all ending screens. + -- debugPrint "Server kills clients" killAllClients -- Verify that the saved perception is equal to future reconstructed. persSaved <- getsServer sper @@ -454,14 +471,15 @@ pers <- getsState $ dungeonPerception cops (fromMaybe (Digital 12) fovMode) assert (persSaved == pers `blame` "wrong saved perception" - `with` (persSaved, pers)) skip + `twith` (persSaved, pers)) skip restartGame :: (MonadAtomic m, MonadConnServer m) => m () -> m () -> m () restartGame updConn loopServer = do cops <- getsState scops sdebugNxt <- getsServer sdebugNxt - s <- gameReset cops sdebugNxt + srandom <- getsServer srandom + s <- gameReset cops sdebugNxt $ Just srandom modifyServer $ \ser -> ser {sdebugNxt, sdebugSer = sdebugNxt} execCmdAtomic $ RestartServerA s updConn 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 @@ -15,9 +15,9 @@ import Data.Maybe import Data.Ratio 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.Common.Action import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState @@ -41,10 +41,8 @@ import Game.LambdaHack.Content.TileKind as TileKind import Game.LambdaHack.Server.Action hiding (sendQueryAI, sendQueryUI, sendUpdateAI, sendUpdateUI) -import Game.LambdaHack.Server.Config import Game.LambdaHack.Server.EffectSem import Game.LambdaHack.Server.State -import Game.LambdaHack.Utils.Assert execFailure :: (MonadAtomic m, MonadServer m) => Actor -> FailureSer -> m () @@ -144,18 +142,19 @@ if bproj sb -- projectile then case itemAssocs of [(iid, item)] -> return (Just iid, item) - _ -> assert `failure` "projectile with wrong items" `with` itemAssocs + _ -> assert `failure` "projectile with wrong items" `twith` itemAssocs 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" - h2hKind <- rndToAction $ opick h2hGroup (const True) + h2hKind <- rndToAction $ fmap (fromMaybe $ assert `failure` h2hGroup) + $ opick h2hGroup (const True) flavour <- getsServer sflavour discoRev <- getsServer sdiscoRev let kind = okind h2hKind - effect = fmap (maxDice . fst) (ieffect kind) + effect = fmap maxDeep (ieffect kind) return ( Nothing , buildItem flavour discoRev h2hKind kind effect ) let performHit block = do @@ -226,7 +225,8 @@ freshClientTile = hideTile cotile lvl tpos changeTo tgroup = do -- No AlterD, because the effect is obvious (e.g., opened door). - toTile <- rndToAction $ opick tgroup (const True) + toTile <- rndToAction $ fmap (fromMaybe $ assert `failure` tgroup) + $ opick tgroup (const True) unless (toTile == serverTile) $ execCmdAtomic $ AlterTileA lid tpos serverTile toTile feats = case mfeat of @@ -274,7 +274,7 @@ pickupSer :: MonadAtomic m => ActorId -> ItemId -> Int -> InvChar -> m () pickupSer aid iid k l = assert (k > 0 `blame` "pick up no items" - `with` (aid, iid, k, l)) $ do + `twith` (aid, iid, k, l)) $ do b <- getsState $ getActorBody aid execCmdAtomic $ MoveItemA iid k (CFloor (blid b) (bpos b)) (CActor aid l) @@ -310,7 +310,7 @@ case bla lxsize lysize eps spos tpos of Nothing -> execFailure sb ProjectAimOnself Just [] -> assert `failure` "projecting from the edge of level" - `with` (spos, tpos) + `twith` (spos, tpos) Just (pos : rest) -> do as <- getsState $ actorList (const True) lid lvl <- getLevel lid @@ -366,6 +366,7 @@ -- * ApplySer +-- TODO: check actor has access to the item applySer :: (MonadAtomic m, MonadServer m) => ActorId -- ^ actor applying the item (is on current level) -> ItemId -- ^ the item to be applied @@ -459,17 +460,3 @@ gameSaveSer = do modifyServer $ \ser -> ser {sbkpSave = True} modifyServer $ \ser -> ser {squit = True} -- do this at once - --- * CfgDumpSer - -cfgDumpSer :: (MonadAtomic m, MonadServer m) => ActorId -> m () -cfgDumpSer aid = do - b <- getsState $ getActorBody aid - let fid = bfid b - Config{configRulesCfgFile} <- getsServer sconfig - let fn = configRulesCfgFile ++ ".dump" - msg = "Server dumped current game rules configuration to file" - <+> T.pack fn <> "." - dumpCfg fn - -- Wait with confirmation until saved; tell where the file is. - execSfxAtomic $ MsgFidD fid msg 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 @@ -15,7 +15,9 @@ import Data.Text (Text) import qualified Data.Text as T 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 @@ -28,6 +30,7 @@ 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 @@ -42,7 +45,6 @@ import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.ServerSem import Game.LambdaHack.Server.State -import Game.LambdaHack.Utils.Assert -- | Apply debug options that don't need a new game. applyDebug :: MonadServer m => m () @@ -56,6 +58,7 @@ , sstopAfter , sdbgMsgSer , snewGameSer + , sdumpConfig , sdebugCli }} initPer :: MonadServer m => m () @@ -99,7 +102,7 @@ lowercase = T.pack . map Char.toLower . T.unpack createFactions :: Kind.COps -> Players -> Rnd FactionDict -createFactions Kind.COps{cofact=Kind.Ops{opick}} players = do +createFactions Kind.COps{cofaction=Kind.Ops{opick}} players = do let rawCreate gplayer@Player{..} = do let cmap = mapFromInvFuns [colorToTeamName, colorToPlainName, colorToFancyName] @@ -109,7 +112,8 @@ (gcolor, gname) = case M.lookup nameoc cmap of Nothing -> (Color.BrWhite, prefix <+> playerName) Just c -> (c, prefix <+> playerName <+> "Team") - gkind <- opick playerFaction (const True) + gkind <- fmap (fromMaybe $ assert `failure` playerFaction) + $ opick playerFaction (const True) let gdipl = EM.empty -- fixed below gquit = Nothing gleader = Nothing @@ -124,7 +128,7 @@ case (findPlayerName name1 lFs, findPlayerName name2 lFs) of (Just (ix1, _), Just (ix2, _)) -> (ix1, ix2) _ -> assert `failure` "unknown faction" - `with` ((name1, name2), lFs) + `twith` ((name1, name2), lFs) ixs = map f l -- Only symmetry is ensured, everything else is permitted, e.g., -- a faction in alliance with two others that are at war. @@ -140,20 +144,22 @@ warFs = mkDipl War allianceFs (swapIx (playersEnemy players)) return warFs -gameReset :: MonadServer m => Kind.COps -> DebugModeSer -> m State +gameReset :: MonadServer m + => Kind.COps -> DebugModeSer -> Maybe R.StdGen -> m State gameReset cops@Kind.COps{coitem, comode=Kind.Ops{opick, okind}, corule} - sdebug = do + 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 + (sconfig, dungeonSeed, srandom) <- mkConfigRules corule mrandom scoreTable <- restoreScore sconfig sstart <- getsServer sstart -- copy over from previous game let smode = sgameMode sdebug rnd :: Rnd (FactionDict, FlavourMap, Discovery, DiscoRev, DungeonGen.FreshDungeon) rnd = do - modeKind <- opick smode (const True) + modeKind <- fmap (fromMaybe $ assert `failure` smode) + $ opick smode (const True) let mode = okind modeKind faction <- createFactions cops $ mplayers mode sflavour <- dungeonFlavourMap coitem @@ -172,10 +178,16 @@ populateDungeon :: (MonadAtomic m, MonadServer m) => m () populateDungeon = do cops@Kind.COps{cotile} <- getsState scops - let initialItems lid (Level{ltile, litemNum}) = + let initialItems lid (Level{ltile, litemNum, lxsize, lysize}) = replicateM litemNum $ do - pos <- rndToAction - $ findPos ltile (const (Tile.hasFeature cotile F.CanItem)) + Level{lfloor} <- getLevel lid + pos <- rndToAction $ findPosTry 1000 ltile + -- try really hard, for skirmish fairness + (const (Tile.hasFeature cotile F.CanItem)) + [ \p _ -> all (flip EM.notMember lfloor) + $ vicinity lxsize lysize p + , \p _ -> EM.notMember p lfloor + ] createItems 1 pos lid dungeon <- getsState sdungeon mapWithKeyM_ initialItems dungeon @@ -184,8 +196,9 @@ let (minD, maxD) = case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) - _ -> assert `failure` "empty dungeon" `with` dungeon - needInitialCrew = EM.assocs factionD + _ -> assert `failure` "empty dungeon" `twith` dungeon + needInitialCrew = filter ((> 0 ) . playerInitial . gplayer . snd) + $ EM.assocs factionD getEntryLevel (_, fact) = max minD $ min maxD $ playerEntry $ gplayer fact arenas = ES.toList $ ES.fromList $ map getEntryLevel needInitialCrew @@ -197,20 +210,20 @@ mapM_ (arenaActors lid) $ zip arenaFactions entryPoss arenaActors _ ((_, Faction{gplayer = Player{playerInitial = 0}}), _) = return () - arenaActors lid ((side, fact@Faction{gplayer}), ppos) = do + arenaActors lid ((side, fact), ppos) = do time <- getsState $ getLocalTime lid let nmult = fromEnum side `mod` 5 -- always positive ntime = timeAdd time (timeScale timeClip nmult) - psFree <- - getsState $ nearbyFreePoints - cotile (Tile.hasFeature cotile F.CanActor) ppos lid - let ps = take (playerInitial gplayer) $ zip [0..] psFree + validTile t = Tile.hasFeature cotile F.CanActor t + psFree <- getsState $ nearbyFreePoints cotile validTile ppos lid + let ps = take (playerInitial $ gplayer fact) $ zip [0..] psFree forM_ ps $ \ (n, p) -> if isSpawnFact cops fact - then spawnMonsters [p] lid ((== side) . fst) ntime "spawn" + then spawnMonsters [p] lid ntime side else do aid <- addHero side p lid configHeroNames (Just n) ntime - mleader <- getsState $ gleader . (EM.! side) . sfactionD + mleader <- getsState + $ gleader . (EM.! side) . sfactionD -- just changed when (isNothing mleader) $ execCmdAtomic $ LeadFactionA side Nothing (Just aid) mapM_ initialActors arenas @@ -218,22 +231,27 @@ -- | Find starting postions for all factions. Try to make them distant -- from each other. If only one faction, also move it away from any stairs. findEntryPoss :: Kind.COps -> Level -> Int -> Rnd [Point] -findEntryPoss Kind.COps{cotile} Level{ltile, lxsize, lysize, lstair} k = +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 tryFind _ 0 = return [] tryFind ps n = do - np <- findPosTry 40 ltile - [ dist ps factionDist - , dist ps $ 2 * factionDist `div` 3 - , dist ps $ factionDist `div` 2 + np <- findPosTry 1000 ltile -- try really hard, for skirmish fairness + (const (Tile.hasFeature cotile F.CanActor)) + [ dist ps $ factionDist `div` 2 , dist ps $ factionDist `div` 3 , dist ps $ factionDist `div` 4 - , dist ps $ factionDist `div` 6 - , const (Tile.hasFeature cotile F.CanActor) + , dist ps $ factionDist `div` 8 + , dist ps $ factionDist `div` 16 ] nps <- tryFind (np : ps) (n - 1) return $ np : nps - stairPoss | k == 1 = fst lstair ++ snd lstair - | otherwise = [] - in tryFind stairPoss k + stairPoss = fst lstair ++ snd lstair + middlePos = toPoint lxsize $ PointXY (lxsize `div` 2, lysize `div` 2) + assert (k > 0 && factionDist > 0) skip + case k of + 1 -> tryFind stairPoss k + 2 -> -- Make sure the first faction's pos is not chosen in the middle. + tryFind [middlePos] k + _ | k > 2 -> tryFind [] k + _ -> assert `failure` 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 @@ -50,6 +50,7 @@ , sstopAfter :: !(Maybe Int) , sfovMode :: !(Maybe FovMode) , snewGameSer :: !Bool + , sdumpConfig :: !Bool , ssavePrefixSer :: !(Maybe String) , sdbgMsgSer :: !Bool , sdebugCli :: !DebugModeCli @@ -87,6 +88,7 @@ , sstopAfter = Nothing , sfovMode = Nothing , snewGameSer = False + , sdumpConfig = False , ssavePrefixSer = Nothing , sdbgMsgSer = False , sdebugCli = defDebugModeCli @@ -132,7 +134,6 @@ put sallClear put sgameMode put sfovMode - put snewGameSer put ssavePrefixSer put sdbgMsgSer put sdebugCli @@ -144,9 +145,10 @@ sallClear <- get sgameMode <- get sfovMode <- get - snewGameSer <- get ssavePrefixSer <- get sdbgMsgSer <- get sdebugCli <- get let sstopAfter = Nothing + snewGameSer = False + sdumpConfig = False return DebugModeSer{..} diff --git a/Game/LambdaHack/Utils/Assert.hs b/Game/LambdaHack/Utils/Assert.hs deleted file mode 100644 --- a/Game/LambdaHack/Utils/Assert.hs +++ /dev/null @@ -1,67 +0,0 @@ --- | Tools for specifying assertions. A step towards contracts. --- Actually, a bunch of hacks wrapping the original @assert@ function, --- which is the only easy way of obtaining source positions. -module Game.LambdaHack.Utils.Assert - ( assert, blame, with, failure, allB, skip, forceEither - ) where - -import Control.Exception (assert) -import Data.Text (Text) -import Debug.Trace (trace) -import qualified Text.Show.Pretty as Show.Pretty - -infix 1 `blame` --- | If the condition fails, display the value blamed for the failure. --- Used as in --- --- > assert (c /= 0 `blame` c) $ 10 / c -blame :: Show a => Bool -> a -> Bool -{-# INLINE blame #-} -blame condition blamed - | condition = True - | otherwise = - let s = "Contract failed and the following is to blame:\n" ++ - " " ++ Show.Pretty.ppShow blamed - in trace s False - -infix 2 `with` -with :: Text -> b -> (Text, b) -with t b = (t, b) - -infix 1 `failure` --- | Like 'error', but shows the source position and also --- the value to blame for the failure. To be used as in: --- --- > assert `failure` ((x1, y1), (x2, y2), "designate a vertical line") -failure :: Show a => (Bool -> b -> b) -> a -> b -{-# INLINE failure #-} -failure asrt blamed = - let s = "Internal failure occured and the following is to blame:\n" ++ - " " ++ Show.Pretty.ppShow blamed - in trace s $ - asrt False - (error "Assert.failure: no error position (upgrade to GHC >= 7.4)") - --- | Like 'List.all', but if the predicate fails, blame all the list elements --- and especially those for which it fails. To be used as in: --- --- > assert (allB (>= 0) [yf, xf, y1, x1, y2, x2]) -allB :: Show a => (a -> Bool) -> [a] -> Bool -{-# INLINE allB #-} -allB predicate l = - let s = Show.Pretty.ppShow (filter (not . predicate) l) - ++ " in the context of " - ++ Show.Pretty.ppShow l - in blame (all predicate l) s - --- | To be used in place of the verbose @skip@, as in: --- --- > do b <- getB a --- > assert (b `blame` a) skip -skip :: Monad m => m () -skip = return () - --- | In case of corruption, just fail and show the error message. -forceEither :: Show a => Either a b -> b -forceEither (Left a) = assert `failure` "unexpected Left" `with` a -forceEither (Right b) = b 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 @@ -52,12 +52,15 @@ unless dirExists $ createDirectory dir -- | Try to copy over data files, if not already there. -tryCopyDataFiles :: (FilePath -> IO FilePath) -> [(FilePath, FilePath)] +tryCopyDataFiles :: FilePath + -> (FilePath -> IO FilePath) + -> [(FilePath, FilePath)] -> IO () -tryCopyDataFiles pathsDataFile files = +tryCopyDataFiles configAppDataDir pathsDataFile files = let cpFile (fin, fout) = do pathsDataIn <- pathsDataFile $ takeFileName fin bIn <- doesFileExist pathsDataIn - bOut <- doesFileExist fout - when (bIn && not bOut) $ copyFile pathsDataIn fout + let pathsDataOut = configAppDataDir fout + bOut <- doesFileExist pathsDataOut + when (not bOut && bIn) $ copyFile pathsDataIn pathsDataOut in mapM_ cpFile files 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 @@ -6,20 +6,22 @@ -- * Construction , uniformFreq, toFreq -- * Transformation - , scaleFreq, renameFreq + , scaleFreq, renameFreq, setFreq -- * Consumption , rollFreq, nullFreq, runFrequency, nameFrequency ) where +import Control.Applicative import Control.Arrow (first, second) import Control.Monad +import Data.Binary import Data.Foldable (Foldable) import Data.Text (Text) import Data.Traversable (Traversable) import qualified System.Random as R +import Control.Exception.Assert.Sugar import Game.LambdaHack.Common.Msg -import Game.LambdaHack.Utils.Assert -- TODO: do not expose runFrequency -- | The frequency distribution type. @@ -27,7 +29,7 @@ { nameFrequency :: !Text -- ^ short description for debug, etc. , runFrequency :: ![(Int, a)] -- ^ give acces to raw frequency values } - deriving (Show, Foldable, Traversable) + deriving (Show, Eq, Foldable, Traversable) instance Monad Frequency where return x = Frequency "return" [(1, x)] @@ -36,6 +38,13 @@ [(p * q, y) | (p, x) <- xs , (q, y) <- runFrequency (f x) ] +instance Functor Frequency where + fmap f (Frequency name xs) = Frequency name (map (second f) xs) + +instance Applicative Frequency where + pure = return + (<*>) = ap + instance MonadPlus Frequency where mplus (Frequency xname xs) (Frequency yname ys) = let name = case (xs, ys) of @@ -46,8 +55,9 @@ in Frequency name (xs ++ ys) mzero = Frequency "[]" [] -instance Functor Frequency where - fmap f (Frequency name xs) = Frequency name (map (second f) xs) +instance Alternative Frequency where + (<|>) = mplus + empty = mzero -- | Uniform discrete frequency distribution. uniformFreq :: Text -> [a] -> Frequency a @@ -62,32 +72,48 @@ -- by a positive integer constant. scaleFreq :: Show a => Int -> Frequency a -> Frequency a scaleFreq n (Frequency name xs) = - assert (n > 0 `blame` "non-positive frequency scale" `with` (name, n, xs)) $ + assert (n > 0 `blame` "non-positive frequency scale" `twith` (name, n, xs)) $ Frequency name (map (first (* n)) xs) -- | Change the description of the frequency. renameFreq :: Text -> Frequency a -> Frequency a renameFreq newName fr = fr {nameFrequency = newName} +-- | Set frequency of an element. +setFreq :: Eq a => Frequency a -> a -> Int -> Frequency a +setFreq (Frequency name xs) x n = + let f (_, y) | y == x = (n, x) + f my = my + in Frequency name $ map f xs + -- | Randomly choose an item according to the distribution. rollFreq :: Show a => Frequency a -> R.StdGen -> (a, R.StdGen) rollFreq (Frequency name []) _ = - assert `failure` "choice from an empty frequency" `with` name + assert `failure` "choice from an empty frequency" `twith` name rollFreq (Frequency name [(n, x)]) _ | n <= 0 = - assert `failure` "singleton void frequency" `with` (name, n, x) + assert `failure` "singleton void frequency" `twith` (name, n, x) rollFreq (Frequency _ [(_, x)]) g = (x, g) -- speedup rollFreq (Frequency name fs) g = - assert (sumf > 0 `blame` "frequency with nothing to pick" `with` (name, fs)) + assert (sumf > 0 `blame` "frequency with nothing to pick" `twith` (name, fs)) (frec r fs, ng) where sumf = sum (map fst fs) (r, ng) = R.randomR (1, sumf) g frec :: Int -> [(Int, a)] -> a frec m [] = assert `failure` "impossible roll" - `with` (name, fs, m) + `twith` (name, fs, m) frec m ((n, x) : _) | m <= n = x frec m ((n, _) : xs) = frec (m - n) xs -- | Test if the frequency distribution is empty. nullFreq :: Frequency a -> Bool -nullFreq = null . runFrequency +nullFreq (Frequency _ fs) = all (== 0) $ map fst fs + +instance Binary a => Binary (Frequency a) where + put Frequency{..} = do + put nameFrequency + put runFrequency + get = do + nameFrequency <- get + runFrequency <- get + return Frequency{..} diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ -Copyright (c) 2008--2012 Andres Loeh -Copyright (c) 2010--2012 Mikolaj Konarski +Copyright (c) 2008--2013 Andres Loeh +Copyright (c) 2010--2013 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 +version: 0.2.10.5 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 @@ -16,10 +16,11 @@ in the strict and type-safe separation of code and content and of clients (human and AI-controlled) and server. . - New in this release are screensaver game modes (AI vs AI), - improved AI (can now climbs stairs, etc.), multiple, - multi-floor staircases, multiple savefiles, configurable - framerate and combat animations and more. + This is a minor release, primarily intended to fix + 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 @@ -47,10 +48,10 @@ bug-reports: http://github.com/kosmikus/LambdaHack/issues license: BSD3 license-file: LICENSE -tested-with: GHC == 7.4.2, GHC == 7.6.1 -data-files: LICENSE, CREDITS, PLAYING.md, README.md, - config.rules.default, config.ui.default, MainMenu.ascii, scores, - Makefile, .travis.yml +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 author: Andres Loeh, Mikolaj Konarski maintainer: Mikolaj Konarski category: Game Engine, Game @@ -78,7 +79,6 @@ Game.LambdaHack.Client.Action, Game.LambdaHack.Client.Action.ActionClass, Game.LambdaHack.Client.Action.ActionType, - Game.LambdaHack.Client.Action.ConfigIO, Game.LambdaHack.Client.AtomicSemCli, Game.LambdaHack.Client.Binding, Game.LambdaHack.Client.ClientSem, @@ -98,12 +98,12 @@ Game.LambdaHack.Common.Actor, Game.LambdaHack.Common.ActorState, Game.LambdaHack.Common.Animation, - Game.LambdaHack.Common.Area, Game.LambdaHack.Common.AtomicCmd, Game.LambdaHack.Common.AtomicPos, 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, @@ -142,10 +142,10 @@ Game.LambdaHack.Server.Action, Game.LambdaHack.Server.Action.ActionClass, Game.LambdaHack.Server.Action.ActionType, - Game.LambdaHack.Server.Action.ConfigIO, Game.LambdaHack.Server.AtomicSemSer, Game.LambdaHack.Server.Config, Game.LambdaHack.Server.DungeonGen, + Game.LambdaHack.Server.DungeonGen.Area Game.LambdaHack.Server.DungeonGen.AreaRnd, Game.LambdaHack.Server.DungeonGen.Cave, Game.LambdaHack.Server.DungeonGen.Place, @@ -159,7 +159,6 @@ Game.LambdaHack.Server.ServerSem, Game.LambdaHack.Server.StartAction, Game.LambdaHack.Server.State, - Game.LambdaHack.Utils.Assert, Game.LambdaHack.Utils.File, Game.LambdaHack.Utils.Frequency, Game.LambdaHack.Utils.LQueue, @@ -167,13 +166,14 @@ other-modules: Paths_LambdaHack build-depends: ConfigFile >= 1.1.1 && < 2, array >= 0.3.0.3 && < 1, + assert-failure >= 0.1 && < 1, base >= 4 && < 5, binary >= 0.7 && < 1, bytestring >= 0.9.2 && < 1, containers >= 0.5 && < 1, deepseq >= 1.3 && < 2, directory >= 1.1.0.1 && < 2, - enummapset >= 0.5.2 && < 1, + enummapset-th >= 0.6.0.0 && < 1, filepath >= 1.2.0.1 && < 2, ghc-prim >= 0.2, hashable >= 1.2 && < 2, @@ -181,10 +181,10 @@ miniutter >= 0.4.1 && < 2, mtl >= 2.0.1 && < 3, old-time >= 1.0.0.7 && < 2, - pretty-show >= 1.6 && < 2, + pretty-show >= 1.6 && < 1.6.2, random >= 1.0.1 && < 2, stm >= 2.4 && < 3, - text >= 0.11.2.3 && < 1, + text >= 0.11.2.3 && < 2, transformers >= 0.3 && < 1, unordered-containers >= 0.2.3 && < 1, zlib >= 0.5.3.1 && < 1 @@ -201,6 +201,7 @@ ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas ghc-options: -fno-warn-auto-orphans -fno-warn-implicit-prelude ghc-options: -fno-ignore-asserts -funbox-strict-fields + ghc-prof-options: -fprof-auto-calls if flag(gtk) { other-modules: Game.LambdaHack.Frontend.Gtk @@ -236,13 +237,14 @@ ConfigFile >= 1.1.1 && < 2, array >= 0.3.0.3 && < 1, + assert-failure >= 0.1 && < 1, base >= 4 && < 5, binary >= 0.7 && < 1, bytestring >= 0.9.2 && < 1, containers >= 0.5 && < 1, deepseq >= 1.3 && < 2, directory >= 1.1.0.1 && < 2, - enummapset >= 0.5.2 && < 1, + enummapset-th >= 0.6.0.0 && < 1, filepath >= 1.2.0.1 && < 2, ghc-prim >= 0.2, hashable >= 1.2 && < 2, @@ -252,7 +254,7 @@ old-time >= 1.0.0.7 && < 2, random >= 1.0.1 && < 2, stm >= 2.4 && < 3, - text >= 0.11.2.3 && < 1, + text >= 0.11.2.3 && < 2, transformers >= 0.3 && < 1, unordered-containers >= 0.2.3 && < 1, zlib >= 0.5.3.1 && < 1 @@ -260,7 +262,7 @@ default-language: Haskell2010 default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings BangPatterns, RecordWildCards, NamedFieldPuns - other-extensions: CPP, TemplateHaskell + other-extensions: TemplateHaskell ghc-options: -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas ghc-options: -fno-warn-auto-orphans -fno-warn-implicit-prelude ghc-options: -fno-ignore-asserts -funbox-strict-fields diff --git a/LambdaHack/Content/CaveKind.hs b/LambdaHack/Content/CaveKind.hs --- a/LambdaHack/Content/CaveKind.hs +++ b/LambdaHack/Content/CaveKind.hs @@ -25,19 +25,23 @@ , cfreq = [("dng", 100), ("caveRogue", 1)] , cxsize = fst normalLevelBound + 1 , cysize = snd normalLevelBound + 1 - , cgrid = RollDiceXY (rollDice 2 3, rollDice 2 2) - , cminPlaceSize = RollDiceXY (rollDice 2 2, rollDice 2 1) - , cdarkChance = (rollDice 1 54, rollDice 0 0) + , 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 - , cvoidChance = 1%4 - , cnonVoidMin = 4 + , cmaxVoid = 1%6 , cminStairDist = 30 , cdoorChance = 1%2 , copenChance = 1%10 , chidden = 8 , citemNum = rollDice 7 2 + , citemFreq = [(70, "useful"), (30, "treasure")] , cdefTile = "fillerWall" - , ccorridorTile = "darkCorridor" + , cdarkCorTile = "floorCorridorDark" + , clitCorTile = "floorCorridorDark" , cfillerTile = "fillerWall" , cdarkLegendTile = "darkLegend" , clitLegendTile = "litLegend" @@ -46,57 +50,67 @@ { csymbol = 'A' , cname = "Underground city" , cfreq = [("dng", 30), ("caveArena", 1)] - , cgrid = RollDiceXY (rollDice 2 2, rollDice 2 2) - , cminPlaceSize = RollDiceXY (rollDice 3 2, rollDice 2 1) - , cdarkChance = (rollDice 1 80, rollDice 1 60) - , cvoidChance = 1%3 - , cnonVoidMin = 2 - , chidden = 9 - , citemNum = rollDice 4 2 -- few rooms - , cdefTile = "floorArenaLit" - , ccorridorTile = "path" + , 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 (rollDice 2 2, rollDice 1 2) - , cminPlaceSize = RollDiceXY (rollDice 4 3, rollDice 4 1) - , cdarkChance = (rollDice 1 80, rollDice 1 80) + , 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 - , cvoidChance = 3%4 - , cnonVoidMin = 1 + , cmaxVoid = 1%2 , cminStairDist = 50 - , chidden = 10 + , chidden = 1000 , citemNum = rollDice 8 2 -- whole floor strewn with treasure - , cdefTile = "floorRoomLit" - , ccorridorTile = "floorRoomLit" + , cdefTile = "emptySet" + , cdarkCorTile = "pathDark" + , clitCorTile = "floorArenaLit" } noise = rogue { csymbol = '!' , cname = "Glittering cave" , cfreq = [("dng", 20), ("caveNoise", 1)] - , cgrid = RollDiceXY (rollDice 2 2, rollDice 1 2) - , cminPlaceSize = RollDiceXY (rollDice 4 2, rollDice 4 1) - , cdarkChance = (rollDice 1 80, rollDice 1 40) - , cvoidChance = 0 - , cnonVoidMin = 0 - , chidden = 6 - , citemNum = rollDice 4 2 -- few rooms + , 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" - , ccorridorTile = "path" + , cdarkCorTile = "pathDark" + , clitCorTile = "pathLit" } combat = rogue { csymbol = 'C' , cname = "Combat arena" , cfreq = [("caveCombat", 1)] - , cgrid = RollDiceXY (rollDice 5 2, rollDice 2 2) - , cminPlaceSize = RollDiceXY (rollDice 1 1, rollDice 1 1) - , cdarkChance = (rollDice 1 100, rollDice 1 100) - , cvoidChance = 1%10 - , cnonVoidMin = 8 - , chidden = 100 + , 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" - , ccorridorTile = "path" + , cdarkCorTile = "pathLit" -- for now, let paths give off light + , clitCorTile = "floorArenaLit" } diff --git a/LambdaHack/Content/ItemKind.hs b/LambdaHack/Content/ItemKind.hs --- a/LambdaHack/Content/ItemKind.hs +++ b/LambdaHack/Content/ItemKind.hs @@ -21,14 +21,14 @@ gem, potion, scroll, wand :: ItemKind -- generic templates --- castDeep (aDb, xDy) = castDice aDb + lvl * castDice xDy / depth +-- castDeep (aDb, xDy) = castDice aDb + (lvl - 1) * castDice xDy / (depth - 1) amulet = ItemKind { isymbol = '"' , iname = "amulet" - , ifreq = [("dng", 6)] + , ifreq = [("useful", 6)] , iflavour = zipFancy [BrGreen] - , ieffect = Regeneration (rollDice 2 3, rollDice 1 10) + , ieffect = Regeneration (rollDeep (2, 3) (1, 10)) , icount = intToDeep 1 , iverbApply = "tear down" , iverbProject = "cast" @@ -38,10 +38,10 @@ dart = ItemKind { isymbol = '|' , iname = "dart" - , ifreq = [("dng", 30)] + , ifreq = [("useful", 20)] , iflavour = zipPlain [Cyan] - , ieffect = Hurt (rollDice 1 1) (rollDice 1 2, rollDice 1 2) - , icount = (rollDice 3 3, rollDice 0 0) + , ieffect = Hurt (rollDice 1 1) (rollDeep (1, 2) (1, 2)) + , icount = rollDeep (3, 3) (0, 0) , iverbApply = "snap" , iverbProject = "hurl" , iweight = 50 @@ -50,7 +50,7 @@ gem = ItemKind { isymbol = '*' , iname = "gem" - , ifreq = [("dng", 20)] -- x3, but rare on shallow levels + , ifreq = [("treasure", 20)] -- x3, but rare on shallow levels , iflavour = zipPlain brightCol -- natural, so not fancy , ieffect = NoEffect , icount = intToDeep 0 @@ -60,21 +60,21 @@ , itoThrow = 0 } gem1 = gem - { icount = (rollDice 0 0, rollDice 1 1) -- appears on lvl 1 + { icount = rollDeep (0, 0) (1, 1) -- appears on max depth } gem2 = gem - { icount = (rollDice 0 0, rollDice 1 2) -- appears halfway + { icount = rollDeep (0, 0) (1, 2) -- appears halfway } gem3 = gem - { icount = (rollDice 0 0, rollDice 1 3) -- appears on max depth + { icount = rollDeep (0, 0) (1, 3) -- appears early } currency = ItemKind { isymbol = '$' , iname = "gold piece" - , ifreq = [("dng", 50), ("currency", 1)] + , ifreq = [("treasure", 20), ("currency", 1)] , iflavour = zipPlain [BrYellow] , ieffect = NoEffect - , icount = (rollDice 0 0, rollDice 10 10) + , icount = rollDeep (0, 0) (10, 10) -- appears on lvl 2 , iverbApply = "grind" , iverbProject = "toss" , iweight = 31 @@ -83,10 +83,10 @@ harpoon = ItemKind { isymbol = '|' , iname = "harpoon" - , ifreq = [("dng", 30)] + , ifreq = [("useful", 25)] , iflavour = zipPlain [Brown] - , ieffect = Hurt (rollDice 1 2) (rollDice 1 2, rollDice 2 2) - , icount = (rollDice 0 0, rollDice 2 2) + , ieffect = Hurt (rollDice 1 2) (rollDeep (1, 2) (2, 2)) + , icount = rollDeep (0, 0) (2, 2) , iverbApply = "break up" , iverbProject = "hurl" , iweight = 4000 @@ -95,7 +95,7 @@ potion = ItemKind { isymbol = '!' , iname = "potion" - , ifreq = [("dng", 15)] + , ifreq = [("useful", 15)] , iflavour = zipFancy stdCol , ieffect = NoEffect , icount = intToDeep 1 @@ -105,22 +105,22 @@ , itoThrow = -50 -- oily, bad grip } potion1 = potion - { ifreq = [("dng", 5)] + { ifreq = [("useful", 5)] , ieffect = ApplyPerfume } potion2 = potion { ieffect = Heal 5 } potion3 = potion - { ifreq = [("dng", 5)] + { ifreq = [("useful", 5)] , ieffect = Heal (-5) } ring = ItemKind { isymbol = '=' , iname = "ring" - , ifreq = [] -- [("dng", 10)] -- TODO: make it useful + , ifreq = [] -- [("useful", 10)] -- TODO: make it useful , iflavour = zipPlain [White] - , ieffect = Searching (rollDice 1 6, rollDice 3 2) + , ieffect = Searching (rollDeep (1, 6) (3, 2)) , icount = intToDeep 1 , iverbApply = "squeeze down" , iverbProject = "toss" @@ -130,7 +130,7 @@ scroll = ItemKind { isymbol = '?' , iname = "scroll" - , ifreq = [("dng", 4)] + , ifreq = [("useful", 4)] , iflavour = zipFancy darkCol -- arcane and old , ieffect = NoEffect , icount = intToDeep 1 @@ -141,7 +141,7 @@ } scroll1 = scroll { ieffect = CallFriend 1 - , ifreq = [("dng", 2)] + , ifreq = [("useful", 2)] } scroll2 = scroll { ieffect = Summon 1 @@ -152,9 +152,9 @@ sword = ItemKind { isymbol = ')' , iname = "sword" - , ifreq = [("dng", 40)] + , ifreq = [("useful", 40)] , iflavour = zipPlain [BrCyan] - , ieffect = Hurt (rollDice 3 1) (rollDice 1 2, rollDice 4 2) + , ieffect = Hurt (rollDice 3 1) (rollDeep (1, 2) (4, 2)) , icount = intToDeep 1 , iverbApply = "hit" , iverbProject = "heave" @@ -164,7 +164,7 @@ wand = ItemKind { isymbol = '/' , iname = "wand" - , ifreq = [("dng", 10)] + , ifreq = [("useful", 10)] , iflavour = zipFancy brightCol , ieffect = NoEffect , icount = intToDeep 1 @@ -177,7 +177,7 @@ { ieffect = Dominate } wand2 = wand - { ifreq = [("dng", 3)] + { ifreq = [("useful", 3)] , ieffect = Heal (-25) } fist = sword diff --git a/LambdaHack/Content/ModeKind.hs b/LambdaHack/Content/ModeKind.hs --- a/LambdaHack/Content/ModeKind.hs +++ b/LambdaHack/Content/ModeKind.hs @@ -108,11 +108,11 @@ playersSkirmish = Players { playersList = [ playerHero {playerName = "White"} - , playerAntiHero {playerName = "Green"} + , playerAntiHero {playerName = "Purple"} , playerHorror ] - , playersEnemy = [ ("White", "Green") + , playersEnemy = [ ("White", "Purple") , ("White", "Horror Den") - , ("Green", "Horror Den") ] + , ("Purple", "Horror Den") ] , playersAlly = [] } playersPvP = Players @@ -192,12 +192,12 @@ playersPeekSkirmish = Players { playersList = [ playerHero {playerName = "White"} - , playerAntiHero { playerName = "Green" + , playerAntiHero { playerName = "Purple" , playerUI = True } , playerHorror ] - , playersEnemy = [ ("White", "Green") + , playersEnemy = [ ("White", "Purple") , ("White", "Horror Den") - , ("Green", "Horror Den") ] + , ("Purple", "Horror Den") ] , playersAlly = [] } diff --git a/LambdaHack/Content/PlaceKind.hs b/LambdaHack/Content/PlaceKind.hs --- a/LambdaHack/Content/PlaceKind.hs +++ b/LambdaHack/Content/PlaceKind.hs @@ -28,7 +28,7 @@ pillar = PlaceKind { psymbol = 'p' , pname = "pillar room" - , pfreq = [("rogue", 1000)] + , pfreq = [("rogue", 1000)] -- larger rooms require support pillars , pcover = CStretch , pfence = FNone , ptopLeft = [ "-----" @@ -47,8 +47,7 @@ ] } pillar3 = pillar - { pfreq = [("rogue", 200)] - , ptopLeft = [ "-----" + { ptopLeft = [ "-----" , "|&.O." , "|...." , "|O..." diff --git a/LambdaHack/Content/TileKind.hs b/LambdaHack/Content/TileKind.hs --- a/LambdaHack/Content/TileKind.hs +++ b/LambdaHack/Content/TileKind.hs @@ -14,13 +14,13 @@ , getFreq = tfreq , validate = tvalidate , content = - [wall, hardRock, pillar, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpDark, stairsUpLit, stairsDark, stairsLit, stairsDownDark, stairsDownLit, escapeUpDark, escapeUpLit, escapeDownDark, escapeDownLit, unknown, pillarCache, floorCorridorLit, floorCorridorDark, floorArenaLit, floorArenaDark, floorItemLit, floorItemDark, floorActorItemLit, floorActorItemDark, floorRed, floorBlue, floorGreen, floorBrown] + [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, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpDark, stairsUpLit, stairsDark, stairsLit, stairsDownDark, stairsDownLit, escapeUpDark, escapeUpLit, escapeDownDark, escapeDownLit, unknown, pillarCache, floorCorridorLit, floorCorridorDark, floorArenaLit, floorArenaDark, floorItemLit, floorItemDark, floorActorItemLit, floorActorItemDark, floorRed, floorBlue, floorGreen, floorBrown :: TileKind +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 = "rock" + , tname = "bedrock" , tfreq = [("fillerWall", 1), ("litLegend", 100), ("darkLegend", 100)] , tcolor = BrWhite , tcolor2 = defFG @@ -28,31 +28,39 @@ } hardRock = TileKind { tsymbol = ' ' - , tname = "hard rock" - , tfreq = [("hard rock", 1)] + , tname = "impenetrable bedrock" + , tfreq = [("outer fence", 1)] , tcolor = BrBlack , tcolor2 = BrBlack , tfeature = [Impenetrable] } pillar = TileKind { tsymbol = 'O' - , tname = "pillar" + , tname = "rock" , tfreq = [ ("cachable", 70) , ("litLegend", 100), ("darkLegend", 100) - , ("noiseSet", 55), ("combatSet", 5) ] + , ("noiseSet", 55), ("combatSet", 3) ] , tcolor = BrWhite , tcolor2 = defFG , tfeature = [] } pillarCache = TileKind { tsymbol = '&' - , tname = "wall cache" + , 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" @@ -213,13 +221,13 @@ floorCorridorLit = TileKind { tsymbol = '#' , tname = "corridor" - , tfreq = [] + , tfreq = [("floorCorridorLit", 1)] , tcolor = BrWhite , tcolor2 = defFG , tfeature = [Walkable, Clear, Lit] } floorCorridorDark = floorCorridorLit - { tfreq = [("darkCorridor", 1)] + { tfreq = [("floorCorridorDark", 1)] -- Disabled, because dark corridors and yellow light does not fit LambdaHack. -- , tcolor = BrYellow -- , tcolor2 = BrBlack @@ -228,55 +236,72 @@ floorArenaLit = floorCorridorLit { tsymbol = '.' , tname = "stone floor" - , tfreq = [("floorArenaLit", 1), ("noiseSet", 100), ("combatSet", 100)] + , tfreq = [ ("floorArenaLit", 1) + , ("arenaSet", 1), ("noiseSet", 100), ("combatSet", 100) ] } floorArenaDark = floorCorridorDark { tsymbol = '.' , tname = "stone floor" - , tfreq = [] + , 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 = [("combatSet", 100)] - , tfeature = CanItem : tfeature floorCorridorLit + { tfreq = [] + , tfeature = CanItem : tfeature floorArenaLit } floorItemDark = floorArenaDark { tfreq = [] - , tfeature = CanItem : tfeature floorCorridorDark + , tfeature = CanItem : tfeature floorArenaDark } floorActorItemLit = floorItemLit - { tfreq = [("litLegend", 100), ("floorRoomLit", 1)] + { tfreq = [("litLegend", 100), ("emptySet", 1)] , tfeature = CanActor : tfeature floorItemLit } floorActorItemDark = floorItemDark - { tfreq = [("darkLegend", 100)] + { tfreq = [("darkLegend", 100), ("emptySet", 1)] , tfeature = CanActor : tfeature floorItemDark } -floorRed = floorArenaLit +floorRedDark = floorArenaDark { tname = "brick pavement" - , tfreq = [("path", 30)] + , tfreq = [("pathDark", 30)] , tcolor = BrRed , tcolor2 = Red - , tfeature = Path : tfeature floorArenaLit + , tfeature = Path : tfeature floorArenaDark } -floorBlue = floorRed +floorRedLit = floorRedDark + { tfreq = [("pathLit", 30)] + , tfeature = Lit : tfeature floorRedDark + } +floorBlueDark = floorRedDark { tname = "granite cobblestones" - , tfreq = [("path", 100)] + , tfreq = [("pathDark", 100)] , tcolor = BrBlue , tcolor2 = Blue } -floorGreen = floorRed +floorBlueLit = floorBlueDark + { tfreq = [("pathLit", 100)] + , tfeature = Lit : tfeature floorBlueDark + } +floorGreenDark = floorRedDark { tname = "mossy stone path" - , tfreq = [("path", 100)] + , tfreq = [("pathDark", 100)] , tcolor = BrGreen , tcolor2 = Green } -floorBrown = floorRed +floorGreenLit = floorGreenDark + { tfreq = [("pathLit", 100)] + , tfeature = Lit : tfeature floorGreenDark + } +floorBrownDark = floorRedDark { tname = "rotting mahogany deck" - , tfreq = [("path", 10)] + , 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 --- a/LambdaHack/Main.hs +++ b/LambdaHack/Main.hs @@ -22,9 +22,13 @@ 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 () @@ -34,13 +38,13 @@ main :: IO () main = let copsSlow = Kind.COps - { coactor = Kind.createOps Content.ActorKind.cdefs - , cocave = Kind.createOps Content.CaveKind.cdefs - , cofact = 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 + { 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/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -1,63 +1,143 @@ -test: test-short test-medium test-long +# All xc* tests assume a profiling build (for stack traces). +# See the install-debug target below or .travis.yml.prof. -test-long: testCampaign-long testCoop-long testDefense-long +install-debug: + cabal install --enable-library-profiling --enable-executable-profiling --ghc-options="-fprof-auto-calls" --disable-optimization -test-medium: testCampaign-medium testCoop-medium testDefense-medium +configure-debug: + cabal configure --enable-library-profiling --enable-executable-profiling --ghc-options="-fprof-auto-calls" --disable-optimization -testCampaign-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --stopAfter 500 > /tmp/stdtest.log -testCampaign-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --stopAfter 60 > /tmp/stdtest.log +xcplay: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer -frontendCampaign: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode screensaver +xcpeekCampaign: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign -testCoop-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --fovMode Permissive --savePrefix test --gameMode testCoop --frontendStd --stopAfter 500 > /tmp/stdtest.log +xcpeekSkirmish: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish -testCoop-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --fovMode Shadow --savePrefix test --gameMode testCoop --frontendStd --stopAfter 60 > /tmp/stdtest.log +xcfrontendCampaign: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode screensaver -frontendCoop: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --fovMode Permissive --savePrefix test --gameMode testCoop +xcfrontendCoop: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --fovMode Permissive --savePrefix test --gameMode testCoop -testDefense-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noAnim --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --stopAfter 500 > /tmp/stdtest.log +xcfrontendDefense: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode testDefense -testDefense-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --stopAfter 60 > /tmp/stdtest.log -frontendDefense: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode testDefense +xctest-travis: xctest-short xctest-medium -test-short: test-short-new test-short-load +xctest: xctest-short xctest-medium xctest-long -test-short-new: - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix campaign --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix skirmish --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix PvP --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix Coop --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix defense --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekCampaign --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekSkirmish --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log +xctest-short: xctest-short-new xctest-short-load -test-short-load: - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix campaign --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix skirmish --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix PvP --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix Coop --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix defense --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log - yes . | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log +xctest-medium: xctestCampaign-medium xctestCoop-medium xctestDefense-medium -test-travis: test-short test-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 + +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 + +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 + +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 + +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 + +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 + +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 + +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 + + +play: + dist/build/LambdaHack/LambdaHack --dbgMsgSer + peekCampaign: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --gameMode peekCampaign peekSkirmish: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --gameMode peekSkirmish + +frontendCampaign: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode screensaver + +frontendCoop: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --fovMode Permissive --savePrefix test --gameMode testCoop + +frontendDefense: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 45 --savePrefix test --gameMode testDefense + + +test-travis: test-short test-medium + +test: test-short test-medium test-long + +test-short: test-short-new test-short-load + +test-medium: testCampaign-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 + +testCampaign-medium: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --gameMode screensaver --frontendStd --dumpConfig --stopAfter 200 > /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 + +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 + +testDefense-long: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noAnim --maxFps 100000 --savePrefix test --gameMode testDefense --frontendStd --stopAfter 1000 > /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 + +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 + +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 # The rest of the makefile is unmaintained at the moment. diff --git a/PLAYING.md b/PLAYING.md --- a/PLAYING.md +++ b/PLAYING.md @@ -31,13 +31,13 @@ floor . corridor # wall (horizontal and vertical) - and | - pillar O - wall cache & + rock or tree O + cache & stairs up < stairs down > open door | and - closed door + - rock blank + 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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -53,8 +53,8 @@ Compatibility notes ------------------- -The current code was tested with GHC 7.6, but should also work with -other GHC versions (see file .travis.yml for GHC 7.4 commands). +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). If you are using the curses or vty frontends, numerical keypad may not work correctly depending on the versions @@ -88,8 +88,8 @@ cabal clean cabal install --enable-library-coverage make test - hpc report --hpcdir=dist/hpc/mix/LambdaHack-0.2.10/ LambdaHack - hpc markup --hpcdir=dist/hpc/mix/LambdaHack-0.2.10/ LambdaHack + hpc report --hpcdir=dist/hpc/mix/LambdaHack-0.2.10.5/ LambdaHack + hpc markup --hpcdir=dist/hpc/mix/LambdaHack-0.2.10.5/ LambdaHack The debug option `--stopAfter` is required for any screensaver mode game invocations that gather HPC info, because HPC needs a clean exit diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,44 @@ +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 + + * improved and configurable mode of squad combat + +0.2.6.5 + + * 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.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 + +0.2.10 + + * screensaver game modes (AI vs AI) + + * improved AI (can now climbs stairs, etc.) + + * multiple, multi-floor staircases + + * multiple savefiles + + * configurable framerate and combat animations diff --git a/config.ui.default b/config.ui.default --- a/config.ui.default +++ b/config.ui.default @@ -26,7 +26,6 @@ ; CTRL-e: GameRestart "defense" ; CTRL-x: GameExit ; CTRL-s: GameSave -; CTRL-d: CfgDump ; Tab: MemberCycle ; ISO_Left_Tab: MemberBack ; I: Inventory