LambdaHack 0.2.10 → 0.2.10.5
raw patch · 76 files changed
+1485/−1186 lines, 76 filesdep +assert-failuredep +enummapset-thdep −enummapsetdep ~pretty-showdep ~text
Dependencies added: assert-failure, enummapset-th
Dependencies removed: enummapset
Dependency ranges changed: pretty-show, text
Files
- .travis.yml +5/−3
- Game/LambdaHack/Client.hs +3/−3
- Game/LambdaHack/Client/Action.hs +52/−7
- Game/LambdaHack/Client/Action/ActionType.hs +6/−0
- Game/LambdaHack/Client/Action/ConfigIO.hs +0/−120
- Game/LambdaHack/Client/AtomicSemCli.hs +7/−7
- Game/LambdaHack/Client/ClientSem.hs +7/−7
- Game/LambdaHack/Client/HumanCmd.hs +2/−5
- Game/LambdaHack/Client/HumanGlobal.hs +6/−13
- Game/LambdaHack/Client/HumanLocal.hs +12/−12
- Game/LambdaHack/Client/HumanSem.hs +2/−3
- Game/LambdaHack/Client/LoopAction.hs +3/−3
- Game/LambdaHack/Client/RunAction.hs +4/−4
- Game/LambdaHack/Client/State.hs +2/−2
- Game/LambdaHack/Client/Strategy.hs +11/−2
- Game/LambdaHack/Client/StrategyAction.hs +7/−7
- Game/LambdaHack/Common/Actor.hs +4/−4
- Game/LambdaHack/Common/ActorState.hs +9/−9
- Game/LambdaHack/Common/Area.hs +0/−62
- Game/LambdaHack/Common/AtomicPos.hs +3/−3
- Game/LambdaHack/Common/AtomicSem.hs +42/−37
- Game/LambdaHack/Common/ConfigIO.hs +97/−0
- Game/LambdaHack/Common/Effect.hs +2/−2
- Game/LambdaHack/Common/Faction.hs +2/−2
- Game/LambdaHack/Common/Item.hs +27/−15
- Game/LambdaHack/Common/Kind.hs +22/−23
- Game/LambdaHack/Common/Level.hs +65/−59
- Game/LambdaHack/Common/Point.hs +4/−5
- Game/LambdaHack/Common/PointXY.hs +8/−3
- Game/LambdaHack/Common/Random.hs +37/−17
- Game/LambdaHack/Common/Save.hs +1/−1
- Game/LambdaHack/Common/ServerCmd.hs +0/−2
- Game/LambdaHack/Common/State.hs +2/−0
- Game/LambdaHack/Common/Tile.hs +10/−6
- Game/LambdaHack/Common/Vector.hs +8/−9
- Game/LambdaHack/Common/VectorXY.hs +16/−1
- Game/LambdaHack/Content/CaveKind.hs +25/−12
- Game/LambdaHack/Content/ItemKind.hs +2/−2
- Game/LambdaHack/Content/TileKind.hs +2/−2
- Game/LambdaHack/Frontend.hs +23/−5
- Game/LambdaHack/Frontend/Curses.hs +2/−2
- Game/LambdaHack/Frontend/Gtk.hs +1/−1
- Game/LambdaHack/Server.hs +3/−1
- Game/LambdaHack/Server/Action.hs +83/−26
- Game/LambdaHack/Server/Action/ActionType.hs +2/−1
- Game/LambdaHack/Server/Action/ConfigIO.hs +0/−152
- Game/LambdaHack/Server/AtomicSemSer.hs +2/−2
- Game/LambdaHack/Server/DungeonGen.hs +32/−13
- Game/LambdaHack/Server/DungeonGen/Area.hs +53/−0
- Game/LambdaHack/Server/DungeonGen/AreaRnd.hs +73/−40
- Game/LambdaHack/Server/DungeonGen/Cave.hs +68/−32
- Game/LambdaHack/Server/DungeonGen/Place.hs +81/−61
- Game/LambdaHack/Server/EffectSem.hs +48/−33
- Game/LambdaHack/Server/Fov/Digital.hs +1/−1
- Game/LambdaHack/Server/Fov/Permissive.hs +1/−1
- Game/LambdaHack/Server/Fov/Shadow.hs +1/−1
- Game/LambdaHack/Server/LoopAction.hs +46/−28
- Game/LambdaHack/Server/ServerSem.hs +10/−23
- Game/LambdaHack/Server/StartAction.hs +48/−30
- Game/LambdaHack/Server/State.hs +4/−2
- Game/LambdaHack/Utils/Assert.hs +0/−67
- Game/LambdaHack/Utils/File.hs +7/−4
- Game/LambdaHack/Utils/Frequency.hs +37/−11
- LICENSE +2/−2
- LambdaHack.cabal +21/−19
- LambdaHack/Content/CaveKind.hs +52/−38
- LambdaHack/Content/ItemKind.hs +26/−26
- LambdaHack/Content/ModeKind.hs +6/−6
- LambdaHack/Content/PlaceKind.hs +2/−3
- LambdaHack/Content/TileKind.hs +51/−26
- LambdaHack/Main.hs +12/−8
- Makefile +119/−39
- PLAYING.md +3/−3
- README.md +4/−4
- changelog +44/−0
- config.ui.default +0/−1
.travis.yml view
@@ -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)
Game/LambdaHack/Client.hs view
@@ -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
Game/LambdaHack/Client/Action.hs view
@@ -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
Game/LambdaHack/Client/Action/ActionType.hs view
@@ -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
− Game/LambdaHack/Client/Action/ConfigIO.hs
@@ -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
Game/LambdaHack/Client/AtomicSemCli.hs view
@@ -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 ()
Game/LambdaHack/Client/ClientSem.hs view
@@ -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})
Game/LambdaHack/Client/HumanCmd.hs view
@@ -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"
Game/LambdaHack/Client/HumanGlobal.hs view
@@ -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
Game/LambdaHack/Client/HumanLocal.hs view
@@ -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
Game/LambdaHack/Client/HumanSem.hs view
@@ -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.
Game/LambdaHack/Client/LoopAction.hs view
@@ -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
Game/LambdaHack/Client/RunAction.hs view
@@ -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)
Game/LambdaHack/Client/State.hs view
@@ -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
Game/LambdaHack/Client/Strategy.hs view
@@ -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
Game/LambdaHack/Client/StrategyAction.hs view
@@ -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
Game/LambdaHack/Common/Actor.hs view
@@ -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
Game/LambdaHack/Common/ActorState.hs view
@@ -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
− Game/LambdaHack/Common/Area.hs
@@ -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)
Game/LambdaHack/Common/AtomicPos.hs view
@@ -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
Game/LambdaHack/Common/AtomicSem.hs view
@@ -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
+ Game/LambdaHack/Common/ConfigIO.hs view
@@ -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
Game/LambdaHack/Common/Effect.hs view
@@ -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
Game/LambdaHack/Common/Faction.hs view
@@ -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
Game/LambdaHack/Common/Item.hs view
@@ -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)
Game/LambdaHack/Common/Kind.hs view
@@ -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.
Game/LambdaHack/Common/Level.hs view
@@ -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{..}
Game/LambdaHack/Common/Point.hs view
@@ -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.
Game/LambdaHack/Common/PointXY.hs view
@@ -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
Game/LambdaHack/Common/Random.hs view
@@ -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
Game/LambdaHack/Common/Save.hs view
@@ -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,
Game/LambdaHack/Common/ServerCmd.hs view
@@ -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
Game/LambdaHack/Common/State.hs view
@@ -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 }
Game/LambdaHack/Common/Tile.hs view
@@ -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 =
Game/LambdaHack/Common/Vector.hs view
@@ -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
Game/LambdaHack/Common/VectorXY.hs view
@@ -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 ]
Game/LambdaHack/Content/CaveKind.hs view
@@ -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)
Game/LambdaHack/Content/ItemKind.hs view
@@ -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 }
Game/LambdaHack/Content/TileKind.hs view
@@ -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
Game/LambdaHack/Frontend.hs view
@@ -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.
Game/LambdaHack/Frontend/Curses.hs view
@@ -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
Game/LambdaHack/Frontend/Gtk.hs view
@@ -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 =
Game/LambdaHack/Server.hs view
@@ -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) =
Game/LambdaHack/Server/Action.hs view
@@ -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)
Game/LambdaHack/Server/Action/ActionType.hs view
@@ -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
− Game/LambdaHack/Server/Action/ConfigIO.hs
@@ -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
Game/LambdaHack/Server/AtomicSemSer.hs view
@@ -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]
Game/LambdaHack/Server/DungeonGen.hs view
@@ -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
+ Game/LambdaHack/Server/DungeonGen/Area.hs view
@@ -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)
Game/LambdaHack/Server/DungeonGen/AreaRnd.hs view
@@ -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.
Game/LambdaHack/Server/DungeonGen/Cave.hs view
@@ -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
Game/LambdaHack/Server/DungeonGen/Place.hs view
@@ -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{..}
Game/LambdaHack/Server/EffectSem.hs view
@@ -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
Game/LambdaHack/Server/Fov/Digital.hs view
@@ -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.
Game/LambdaHack/Server/Fov/Permissive.hs view
@@ -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.
Game/LambdaHack/Server/Fov/Shadow.hs view
@@ -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
Game/LambdaHack/Server/LoopAction.hs view
@@ -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
Game/LambdaHack/Server/ServerSem.hs view
@@ -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
Game/LambdaHack/Server/StartAction.hs view
@@ -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
Game/LambdaHack/Server/State.hs view
@@ -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{..}
− Game/LambdaHack/Utils/Assert.hs
@@ -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
Game/LambdaHack/Utils/File.hs view
@@ -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
Game/LambdaHack/Utils/Frequency.hs view
@@ -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{..}
LICENSE view
@@ -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.
LambdaHack.cabal view
@@ -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 <mikolaj.konarski@funktory.com> 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
LambdaHack/Content/CaveKind.hs view
@@ -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" }
LambdaHack/Content/ItemKind.hs view
@@ -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
LambdaHack/Content/ModeKind.hs view
@@ -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 = [] }
LambdaHack/Content/PlaceKind.hs view
@@ -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..."
LambdaHack/Content/TileKind.hs view
@@ -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 }
LambdaHack/Main.hs view
@@ -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
Makefile view
@@ -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.
PLAYING.md view
@@ -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.
README.md view
@@ -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
+ changelog view
@@ -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
config.ui.default view
@@ -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