diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,22 @@ +## [v0.7.0.0, aka 'The dice are cast'](https://github.com/LambdaHack/LambdaHack/compare/v0.6.2.0...v0.7.0.0) + +- decouple tile searching from tile alteration +- refrain from identifying items that are not randomized +- switch away from incapacitated leader to let others revive him +- make rescue easier by not going into negative HP the first time +- fix crowd of friends on another level slowing even actors that melee +- fix missing report about items underneath an actor when changing levels +- API breakage: change the syntax of dice in content +- API addition: introduce cave descriptions +- keep all client states in the server and optimize communication with clients +- improve item choice for identification and item polymorphing +- reset embedded items when altering tile +- replace atomic command filtering with exception catching +- reimplement dice as symbolic expressions inducing multiple RNG calls +- switch to optparse-applicative and rewrite cli handling +- add stack and cabal new-build project files +- improve haddocks across the codebase + ## [v0.6.2.0, aka 'Zoom out'](https://github.com/LambdaHack/LambdaHack/compare/v0.6.1.0...v0.6.2.0) - make fireworks slower and so easier to spot diff --git a/CREDITS b/CREDITS --- a/CREDITS +++ b/CREDITS @@ -4,6 +4,7 @@ Andres Loeh Mikolaj Konarski Tuukka Turto +Veronika Romashkina Fonts 16x16x.fon, 8x8x.fon and 8x8xb.fon are are taken from diff --git a/Game/LambdaHack/Atomic.hs b/Game/LambdaHack/Atomic.hs --- a/Game/LambdaHack/Atomic.hs +++ b/Game/LambdaHack/Atomic.hs @@ -1,26 +1,22 @@ --- | Atomic game state transformations. +-- | Atomic game state transformations, their representation and semantics. -- -- See -- . module Game.LambdaHack.Atomic - ( -- * Re-exported from "Game.LambdaHack.Atomic.MonadAtomic" - MonadAtomic(..) - -- * Re-exported from "Game.LambdaHack.Atomic.CmdAtomic" - , CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), SfxMsg(..) + ( -- * Re-exported from "Game.LambdaHack.Atomic.CmdAtomic" + CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), SfxMsg(..) + -- * Re-exported from "Game.LambdaHack.Atomic.HandleAtomicWrite" + , handleUpdAtomic -- * Re-exported from "Game.LambdaHack.Atomic.PosAtomicRead" , PosAtomic(..), posUpdAtomic, posSfxAtomic, breakUpdAtomic - , seenAtomicCli, seenAtomicSer, generalMoveItem - , posProjBody + , seenAtomicCli, seenAtomicSer -- * Re-exported from "Game.LambdaHack.Atomic.MonadStateWrite" - , MonadStateWrite(..) - -- * Re-exported from "Game.LambdaHack.Atomic.HandleAtomicWrite" - , handleUpdAtomic + , MonadStateWrite(..), AtomicFail(..), putState ) where import Prelude () import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Atomic.HandleAtomicWrite -import Game.LambdaHack.Atomic.MonadAtomic import Game.LambdaHack.Atomic.MonadStateWrite import Game.LambdaHack.Atomic.PosAtomicRead diff --git a/Game/LambdaHack/Atomic/CmdAtomic.hs b/Game/LambdaHack/Atomic/CmdAtomic.hs --- a/Game/LambdaHack/Atomic/CmdAtomic.hs +++ b/Game/LambdaHack/Atomic/CmdAtomic.hs @@ -8,7 +8,7 @@ -- For example item removal from inventory is not an atomic command, -- but item dropped from the inventory to the ground is. This makes -- it easier to undo the commands. In principle, the commands are the only --- way to affect the basic game state (@State@). +-- way to affect the basic game state ('State'). -- -- See -- . @@ -25,23 +25,27 @@ import Data.Int (Int64) import GHC.Generics (Generic) -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ClientOptions +-- Dependence on ClientOptions is an anomaly. Instead, probably the raw +-- remaining commandline should be passed and parsed by the client to extract +-- client and ui options from and singnal an error if anything was left. + +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.TileKind (TileKind) +import Game.LambdaHack.Content.TileKind (TileKind) -- | Abstract syntax of atomic commands, that is, atomic game state -- transformations. @@ -53,9 +57,9 @@ instance Binary CmdAtomic -- | Abstract syntax of atomic updates, that is, atomic commands --- that really change the state. Most of them are an encoding of a game +-- that really change the 'State'. Most of them are an encoding of a game -- state diff, though they also carry some intentional hints --- that help clients determine whether and how to communicate them to players. +-- that help clients determine whether and how to communicate it to players. data UpdAtomic = -- Create/destroy actors and items. UpdCreateActor ActorId Actor [(ItemId, Item)] @@ -66,6 +70,8 @@ | UpdLoseActor ActorId Actor [(ItemId, Item)] | UpdSpotItem Bool ItemId Item ItemQuant Container | UpdLoseItem Bool ItemId Item ItemQuant Container + | UpdSpotItemBag Container ItemBag [(ItemId, Item)] + | UpdLoseItemBag Container ItemBag [(ItemId, Item)] -- Move actors and items. | UpdMoveActor ActorId Point Point | UpdWaitActor ActorId Bool @@ -98,24 +104,25 @@ | UpdUnAgeGame [LevelId] | UpdDiscover Container ItemId (Kind.Id ItemKind) ItemSeed | UpdCover Container ItemId (Kind.Id ItemKind) ItemSeed - | UpdDiscoverKind Container ItemId (Kind.Id ItemKind) - | UpdCoverKind Container ItemId (Kind.Id ItemKind) + | UpdDiscoverKind Container ItemKindIx (Kind.Id ItemKind) + | UpdCoverKind Container ItemKindIx (Kind.Id ItemKind) | UpdDiscoverSeed Container ItemId ItemSeed | UpdCoverSeed Container ItemId ItemSeed + | UpdDiscoverServer ItemId AspectRecord + | UpdCoverServer ItemId AspectRecord | UpdPerception LevelId Perception Perception - | UpdRestart FactionId DiscoveryKind PerLid State Challenge DebugModeCli + | UpdRestart FactionId PerLid State Challenge ClientOptions | UpdRestartServer State | UpdResume FactionId PerLid | UpdResumeServer State | UpdKillExit FactionId | UpdWriteSave - | UpdMsgAll Text deriving (Show, Eq, Generic) instance Binary UpdAtomic -- | Abstract syntax of atomic special effects, that is, atomic commands --- that only display special effects and don't change the state. +-- that only display special effects and don't change 'State'. data SfxAtomic = SfxStrike ActorId ActorId ItemId CStore | SfxRecoil ActorId ActorId ItemId CStore @@ -129,10 +136,13 @@ | SfxShun ActorId Point | SfxEffect FactionId ActorId IK.Effect Int64 | SfxMsgFid FactionId SfxMsg + | SfxSortSlots deriving (Show, Eq, Generic) instance Binary SfxAtomic +-- | Symbolic representation of text messages sent by server to clients +-- and shown to players. data SfxMsg = SfxUnexpected ReqFailure | SfxLoudUpd Bool UpdAtomic @@ -147,7 +157,7 @@ | SfxBracedImmune ActorId | SfxEscapeImpossible | SfxTransImpossible - | SfxIdentifyNothing CStore + | SfxIdentifyNothing | SfxPurposeNothing CStore | SfxPurposeTooFew Int Int | SfxPurposeUnique @@ -167,6 +177,8 @@ UpdLoseActor aid body ais -> Just $ UpdSpotActor aid body ais UpdSpotItem verbose iid item k c -> Just $ UpdLoseItem verbose iid item k c UpdLoseItem verbose iid item k c -> Just $ UpdSpotItem verbose iid item k c + UpdSpotItemBag c bag ais -> Just $ UpdLoseItemBag c bag ais + UpdLoseItemBag c bag ais -> Just $ UpdSpotItemBag c bag ais UpdMoveActor aid fromP toP -> Just $ UpdMoveActor aid toP fromP UpdWaitActor aid toWait -> Just $ UpdWaitActor aid (not toWait) UpdDisplaceActor source target -> Just $ UpdDisplaceActor target source @@ -196,10 +208,12 @@ UpdUnAgeGame lids -> Just $ UpdAgeGame lids UpdDiscover c iid ik seed -> Just $ UpdCover c iid ik seed UpdCover c iid ik seed -> Just $ UpdDiscover c iid ik seed - UpdDiscoverKind c iid ik -> Just $ UpdCoverKind c iid ik - UpdCoverKind c iid ik -> Just $ UpdDiscoverKind c iid ik + UpdDiscoverKind c ix ik -> Just $ UpdCoverKind c ix ik + UpdCoverKind c ix ik -> Just $ UpdDiscoverKind c ix ik UpdDiscoverSeed c iid seed -> Just $ UpdCoverSeed c iid seed UpdCoverSeed c iid seed -> Just $ UpdDiscoverSeed c iid seed + UpdDiscoverServer iid aspectRecord -> Just $ UpdCoverServer iid aspectRecord + UpdCoverServer iid aspectRecord -> Just $ UpdDiscoverServer iid aspectRecord UpdPerception lid outPer inPer -> Just $ UpdPerception lid inPer outPer UpdRestart{} -> Just cmd -- here history ends; change direction UpdRestartServer{} -> Just cmd -- here history ends; change direction @@ -207,7 +221,6 @@ UpdResumeServer{} -> Nothing UpdKillExit{} -> Nothing UpdWriteSave -> Nothing - UpdMsgAll{} -> Nothing -- only generated by @cmdAtomicFilterCli@ or as a hack undoSfxAtomic :: SfxAtomic -> SfxAtomic undoSfxAtomic cmd = case cmd of @@ -223,6 +236,7 @@ SfxShun aid p -> SfxTrigger aid p SfxEffect{} -> cmd -- not ideal? SfxMsgFid{} -> cmd + SfxSortSlots -> cmd undoCmdAtomic :: CmdAtomic -> Maybe CmdAtomic undoCmdAtomic (UpdAtomic cmd) = UpdAtomic <$> undoUpdAtomic cmd diff --git a/Game/LambdaHack/Atomic/HandleAtomicWrite.hs b/Game/LambdaHack/Atomic/HandleAtomicWrite.hs --- a/Game/LambdaHack/Atomic/HandleAtomicWrite.hs +++ b/Game/LambdaHack/Atomic/HandleAtomicWrite.hs @@ -1,4 +1,5 @@ -- | Semantics of atomic commands shared by client and server. +-- -- See -- . module Game.LambdaHack.Atomic.HandleAtomicWrite @@ -6,13 +7,18 @@ #ifdef EXPOSE_INTERNAL -- * Internal operations , updCreateActor, updDestroyActor, updCreateItem, updDestroyItem + , updSpotItemBag, updLoseItemBag , updMoveActor, updWaitActor, updDisplaceActor, updMoveItem , updRefillHP, updRefillCalm , updTrajectory, updQuitFaction, updLeadFaction , updDiplFaction, updTacticFaction, updAutoFaction, updRecordKill - , updAlterTile, updAlterExplorable, updSpotTile, updLoseTile + , updAlterTile, updAlterExplorable, updSearchTile, updSpotTile, updLoseTile , updAlterSmell, updSpotSmell, updLoseSmell, updTimeItem - , updAgeGame, updUnAgeGame, updRestart, updRestartServer, updResumeServer + , updAgeGame, updUnAgeGame, ageLevel, updDiscover, updCover + , updDiscoverKind, discoverKind, updCoverKind + , updDiscoverSeed, discoverSeed, updCoverSeed + , updDiscoverServer, updCoverServer + , updRestart, updRestartServer, updResumeServer #endif ) where @@ -21,31 +27,44 @@ import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM -import Data.Int (Int64) +import Data.Int (Int64) -import Game.LambdaHack.Atomic.CmdAtomic -import Game.LambdaHack.Atomic.MonadStateWrite -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Atomic.CmdAtomic +import Game.LambdaHack.Atomic.MonadStateWrite +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.ItemKind (ItemKind) -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.TileKind (TileKind, unknownId) +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.TileKind (TileKind, unknownId) -- | The game-state semantics of atomic game commands. --- Special effects (@SfxAtomic@) don't modify state. +-- There is no corresponding definition for special effects (`SfxAtomic`), +-- because they don't modify 'State'. +-- +-- For each of the commands, we are guaranteed that the client, +-- the command is addressed to, perceives all the positions the command +-- affects (as computed by 'Game.LambdaHack.Atomic.PosAtomicRead.posUpdAtomic'). +-- In the code for each semantic function we additonally verify +-- the client is aware of any relevant items and/or actors and we throw +-- the @AtomicFail@ exception if it's not. +-- The server keeps copies of all clients' states and, before sending a command +-- to a client, applies it to the client's state copy. +-- If @AtomicFail@ is signalled, the command is ignored for that client. +-- This enables simpler server code that addresses commands to all clients +-- that can see it, even though not all are able to process it. handleUpdAtomic :: MonadStateWrite m => UpdAtomic -> m () handleUpdAtomic cmd = case cmd of UpdCreateActor aid body ais -> updCreateActor aid body ais @@ -56,6 +75,8 @@ UpdLoseActor aid body ais -> updDestroyActor aid body ais UpdSpotItem _ iid item kit c -> updCreateItem iid item kit c UpdLoseItem _ iid item kit c -> updDestroyItem iid item kit c + UpdSpotItemBag c bag ais -> updSpotItemBag c bag ais + UpdLoseItemBag c bag ais -> updLoseItemBag c bag ais UpdMoveActor aid fromP toP -> updMoveActor aid fromP toP UpdWaitActor aid toWait -> updWaitActor aid toWait UpdDisplaceActor source target -> updDisplaceActor source target @@ -72,8 +93,8 @@ UpdRecordKill aid ikind k -> updRecordKill aid ikind k UpdAlterTile lid p fromTile toTile -> updAlterTile lid p fromTile toTile UpdAlterExplorable lid delta -> updAlterExplorable lid delta - UpdSearchTile{} -> return () -- only for clients - UpdHideTile{} -> return () -- only for clients + UpdSearchTile aid p toTile -> updSearchTile aid p toTile + UpdHideTile{} -> undefined UpdSpotTile lid ts -> updSpotTile lid ts UpdLoseTile lid ts -> updLoseTile lid ts UpdAlterSmell lid p fromSm toSm -> updAlterSmell lid p fromSm toSm @@ -82,69 +103,59 @@ UpdTimeItem iid c fromIt toIt -> updTimeItem iid c fromIt toIt UpdAgeGame lids -> updAgeGame lids UpdUnAgeGame lids -> updUnAgeGame lids - UpdDiscover{} -> return () -- We can't keep dicovered data in State, - UpdCover{} -> return () -- because server saves all atomic commands - UpdDiscoverKind{} -> return () -- to apply their inverses for undo, - UpdCoverKind{} -> return () -- so they would wipe out server knowledge. - UpdDiscoverSeed{} -> return () - UpdCoverSeed{} -> return () + UpdDiscover c iid ik seed -> updDiscover c iid ik seed + UpdCover c iid ik seed -> updCover c iid ik seed + UpdDiscoverKind c ix ik -> updDiscoverKind c ix ik + UpdCoverKind c ix ik -> updCoverKind c ix ik + UpdDiscoverSeed c iid seed -> updDiscoverSeed c iid seed + UpdCoverSeed c iid seed -> updCoverSeed c iid seed + UpdDiscoverServer iid aspectRecord -> updDiscoverServer iid aspectRecord + UpdCoverServer iid aspectRecord -> updCoverServer iid aspectRecord UpdPerception _ outPer inPer -> assert (not (nullPer outPer && nullPer inPer)) (return ()) - UpdRestart _ _ _ s _ _ -> updRestart s + UpdRestart _ _ s _ _ -> updRestart s UpdRestartServer s -> updRestartServer s UpdResume{} -> return () UpdResumeServer s -> updResumeServer s UpdKillExit{} -> return () UpdWriteSave -> return () - UpdMsgAll{} -> return () --- | Creates an actor. Note: after this command, usually a new leader +-- Note: after this command, usually a new leader -- for the party should be elected (in case this actor is the only one alive). updCreateActor :: MonadStateWrite m => ActorId -> Actor -> [(ItemId, Item)] -> m () updCreateActor aid body ais = do -- Add actor to @sactorD@. + -- The exception is possible, e.g., when we teleport and so see our actor + -- at the new location, but also the location is part of new perception, + -- so @UpdSpotActor@ is sent. let f Nothing = Just body - f (Just b) = error $ "actor already added" - `showFailure` (aid, body, b) + f (Just b) = assert (body == b `blame` (aid, body, b)) $ + atomicFail $ "actor already added" `showFailure` (aid, body, b) modifyState $ updateActorD $ EM.alter f aid -- Add actor to @sprio@. let g Nothing = Just [aid] g (Just l) = #ifdef WITH_EXPENSIVE_ASSERTIONS + -- Not so much expensive, as doubly impossible. assert (aid `notElem` l `blame` "actor already added" `swith` (aid, body, l)) #endif (Just $ aid : l) updateLevel (blid body) $ updateActorMap (EM.alter g (bpos body)) - -- Actor's items may or may not be already present in @sitemD@, - -- regardless if they are already present otherwise in the dungeon. - -- We re-add them all to save time determining which really need it. - forM_ ais $ \(iid, item) -> do - let h item1 item2 = - assert (itemsMatch item1 item2 - `blame` "inconsistent created actor items" - `swith` (aid, body, iid, item1, item2)) - item2 -- keep the first found level - modifyState $ updateItemD $ EM.insertWith h iid item - -itemsMatch :: Item -> Item -> Bool -itemsMatch item1 item2 = - jkindIx item1 == jkindIx item2 - -- && aspects and effects are the same, but too much writing; - -- Note that nothing else needs to be the same, since items are merged - -- and clients have different views on dungeon items than the server. + addAis ais + aspectRecord <- getsState $ aspectRecordFromActor body + modifyState $ updateActorAspect $ EM.insert aid aspectRecord --- | Kills an actor. +-- If a leader dies, a new leader should be elected on the server +-- before this command is executed (not checked). updDestroyActor :: MonadStateWrite m => ActorId -> Actor -> [(ItemId, Item)] -> m () updDestroyActor aid body ais = do - -- If a leader dies, a new leader should be elected on the server - -- before this command is executed (not checked). - itemD <- getsState sitemD - let match (iid, item) = itemsMatch (itemD EM.! iid) item -- 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) = itemsMatch (itemD EM.! iid) item let !_A = assert (allB match ais `blame` "destroyed actor items not found" `swith` (aid, body, ais, itemD)) () -- Remove actor from @sactorD@. @@ -156,31 +167,32 @@ let g Nothing = error $ "actor already removed" `showFailure` (aid, body) g (Just l) = #ifdef WITH_EXPENSIVE_ASSERTIONS + -- Not so much expensive, as doubly impossible. assert (aid `elem` l `blame` "actor already removed" `swith` (aid, body, l)) #endif (let l2 = delete aid l in if null l2 then Nothing else Just l2) updateLevel (blid body) $ updateActorMap (EM.alter g (bpos body)) + modifyState $ updateActorAspect $ EM.delete aid --- | Create a few copies of an item that is already registered for the dungeon +-- Create a few copies of an item that is already registered for the dungeon -- (in @sitemRev@ field of @StateServer@). updCreateItem :: MonadStateWrite m => ItemId -> Item -> ItemQuant -> Container -> m () updCreateItem iid item kit@(k, _) c = assert (k > 0) $ do - -- The item may or may not be already present in @sitemD@, - -- regardless if it's actually present in the dungeon. - -- If items equivalent, pick the one found on easier level. - let f item1 item2 = - assert (itemsMatch item1 item2) - item2 -- keep the first found level - modifyState $ updateItemD $ EM.insertWith f iid item + addAis [(iid, item)] insertItemContainer iid kit c + case c of + CActor aid store -> + when (store `elem` [CEqp, COrgan]) $ addItemToActor iid item k aid + _ -> return () --- | Destroy some copies (possibly not all) of an item. +-- Destroy some copies (possibly not all) of an item. updDestroyItem :: MonadStateWrite m => ItemId -> Item -> ItemQuant -> Container -> m () updDestroyItem iid item kit@(k, _) c = assert (k > 0) $ do + deleteItemContainer iid kit c -- Do not remove the item from @sitemD@ nor from @sitemRev@, -- It's incredibly costly and not noticeable for the player. -- However, assert the item is registered in @sitemD@. @@ -190,8 +202,43 @@ Just item0 -> itemsMatch item0 item) `blame` "item already removed" `swith` (iid, item, itemD)) () - deleteItemContainer iid kit c + case c of + CActor aid store -> + when (store `elem` [CEqp, COrgan]) $ addItemToActor iid item (-k) aid + _ -> return () +updSpotItemBag :: MonadStateWrite m + => Container -> ItemBag -> [(ItemId, Item)] -> m () +updSpotItemBag c bag ais = assert (EM.size bag > 0 + && EM.size bag == length ais) $ do + addAis ais + insertBagContainer bag c + case c of + CActor aid store -> + when (store `elem` [CEqp, COrgan]) $ + forM_ ais $ \(iid, item) -> + addItemToActor iid item (fst $ bag EM.! iid) aid + _ -> return () + +updLoseItemBag :: MonadStateWrite m + => Container -> ItemBag -> [(ItemId, Item)] -> m () +updLoseItemBag c bag ais = assert (EM.size bag > 0 + && EM.size bag == length ais) $ do + deleteBagContainer bag c + -- Do not remove the items from @sitemD@ nor from @sitemRev@, + -- It's incredibly costly and not noticeable for the player. + -- However, assert the items are registered in @sitemD@. + itemD <- getsState sitemD + let match (iid, item) = itemsMatch (itemD EM.! iid) item + let !_A = assert (allB match ais `blame` "items already removed" + `swith` (c, bag, ais, itemD)) () + case c of + CActor aid store -> + when (store `elem` [CEqp, COrgan]) $ + forM_ ais $ \(iid, item) -> + addItemToActor iid item (- (fst $ bag EM.! iid)) aid + _ -> return () + updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m () updMoveActor aid fromP toP = assert (fromP /= toP) $ do body <- getsState $ getActorBody aid @@ -226,30 +273,49 @@ updMoveItem :: MonadStateWrite m => ItemId -> Int -> ActorId -> CStore -> CStore -> m () -updMoveItem iid k aid c1 c2 = assert (k > 0 && c1 /= c2) $ do +updMoveItem iid k aid s1 s2 = assert (k > 0 && s1 /= s2) $ do b <- getsState $ getActorBody aid - bag <- getsState $ getBodyStoreBag b c1 + bag <- getsState $ getBodyStoreBag b s1 case iid `EM.lookup` bag of - Nothing -> error $ "" `showFailure` (iid, k, aid, c1, c2) + Nothing -> error $ "" `showFailure` (iid, k, aid, s1, s2) Just (_, it) -> do - deleteItemActor iid (k, take k it) aid c1 - insertItemActor iid (k, take k it) aid c2 + deleteItemActor iid (k, take k it) aid s1 + insertItemActor iid (k, take k it) aid s2 + case s1 of + CEqp -> case s2 of + COrgan -> return () + _ -> do + itemBase <- getsState $ getItemBody iid + addItemToActor iid itemBase (-k) aid + COrgan -> case s2 of + CEqp -> return () + _ -> do + itemBase <- getsState $ getItemBody iid + addItemToActor iid itemBase (-k) aid + _ -> + when (s2 `elem` [CEqp, COrgan]) $ do + itemBase <- getsState $ getItemBody iid + addItemToActor iid itemBase k aid updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m () -updRefillHP aid n = +updRefillHP aid nRaw = updateActor aid $ \b -> - b { bhp = bhp b + n - , bhpDelta = let oldD = bhpDelta b - in case compare n 0 of - EQ -> ResDelta { resCurrentTurn = (0, 0) - , resPreviousTurn = resCurrentTurn oldD } - LT -> oldD {resCurrentTurn = - ( fst (resCurrentTurn oldD) + n - , snd (resCurrentTurn oldD) )} - GT -> oldD {resCurrentTurn = - ( fst (resCurrentTurn oldD) - , snd (resCurrentTurn oldD) + n )} - } + -- Make rescue easier by not going into negative HP the first time. + let newRawHP = bhp b + nRaw + newHP = if bhp b <= 0 then newRawHP else max 0 newRawHP + n = newHP - bhp b + in b { bhp = newHP + , bhpDelta = let oldD = bhpDelta b + in case compare n 0 of + EQ -> ResDelta { resCurrentTurn = (0, 0) + , resPreviousTurn = resCurrentTurn oldD } + LT -> oldD {resCurrentTurn = + ( fst (resCurrentTurn oldD) + n + , snd (resCurrentTurn oldD) )} + GT -> oldD {resCurrentTurn = + ( fst (resCurrentTurn oldD) + , snd (resCurrentTurn oldD) + n )} + } updRefillCalm :: MonadStateWrite m => ActorId -> Int64 -> m () updRefillCalm aid n = @@ -303,7 +369,7 @@ mtb <- getsState $ \s -> flip getActorBody s <$> target let !_A = assert (maybe True (not . bproj) mtb `blame` (fid, source, target, mtb, fact)) () - let !_A = assert (source == _gleader fact + let !_A = assert (source == gleader fact `blame` "unexpected actor leader" `swith` (fid, source, target, mtb, fact)) () let adj fa = fa {_gleader = target} @@ -323,12 +389,6 @@ updateFaction fid1 (adj fid2) updateFaction fid2 (adj fid1) -updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m () -updAutoFaction fid st = - updateFaction fid (\fact -> - assert (isAIFact fact == not st) - $ fact {gplayer = automatePlayer st (gplayer fact)}) - updTacticFaction :: MonadStateWrite m => FactionId -> Tactic -> Tactic -> m () updTacticFaction fid toT fromT = do let adj fact = @@ -337,7 +397,13 @@ $ fact {gplayer = player {ftactic = toT}} updateFaction fid adj --- | Record a given number (usually just 1, or -1 for undo) of actor kills +updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m () +updAutoFaction fid st = + updateFaction fid (\fact -> + assert (isAIFact fact == not st) + $ fact {gplayer = automatePlayer st (gplayer fact)}) + +-- Record a given number (usually just 1, or -1 for undo) of actor kills -- for score calculation. updRecordKill :: MonadStateWrite m => ActorId -> Kind.Id ItemKind -> Int -> m () updRecordKill aid ikind k = do @@ -354,76 +420,74 @@ -- as it could be and there is a higher chance of getting back alive -- the actor, the human player has grown attached to. --- | Alter an attribute (actually, the only, the defining attribute) +-- Alter an attribute (actually, the only, the defining attribute) -- of a visible tile. This is similar to e.g., @UpdTrajectory@. -- --- For now, we don't remove embedded items when altering a tile --- and neither do we create fresh ones. It works fine, e.g., for tiles on fire --- that change into burnt out tile and then the fire item can no longer --- be triggered due to @alterMinSkillKind@ excluding items without @Embed@, --- even if the burnt tile has low enough @talter@. +-- Removing and creating embedded items when altering a tile +-- is done separately via @UpdCreateItem@ and @UpdDestroyItem@. updAlterTile :: MonadStateWrite m => LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind -> m () updAlterTile lid p fromTile toTile = assert (fromTile /= toTile) $ do - Kind.COps{cotile, coTileSpeedup} <- getsState scops + Kind.COps{coTileSpeedup} <- getsState scops lvl <- getLevel lid - -- The second alternative below can happen if, e.g., a client remembers, - -- but does not see the tile (so does not notice the SearchTile action), - -- and it suddenly changes into another tile, - -- which at the same time becomes visible (e.g., an open door). - let adj ts = assert (ts PointArray.! p == fromTile - || ts PointArray.! p == Tile.hideAs cotile fromTile - `blame` "unexpected altered tile kind" - `swith` (lid, p, fromTile, toTile, ts PointArray.! p)) - $ ts PointArray.// [(p, toTile)] - updateLevel lid $ updateTile adj - case ( Tile.isExplorable coTileSpeedup fromTile - , Tile.isExplorable coTileSpeedup toTile ) of - (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl + 1} - (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl - 1} - _ -> return () + let t = lvl `at` p + if t /= fromTile + then atomicFail "tile to alter is different than assumed" + else do + let adj ts = ts PointArray.// [(p, toTile)] + updateLevel lid $ updateTile adj + case ( Tile.isExplorable coTileSpeedup fromTile + , Tile.isExplorable coTileSpeedup toTile ) of + (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl + 1} + (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl - 1} + _ -> return () updAlterExplorable :: MonadStateWrite m => LevelId -> Int -> m () updAlterExplorable lid delta = assert (delta /= 0) $ updateLevel lid $ \lvl -> lvl {lexplorable = lexplorable lvl + delta} --- Notice previously invisible tiles. This is similar to @UpdSpotActor@, --- but done in bulk, because it often involves dozens of tiles pers move. --- We don't check that the tiles at the positions in question are unknown --- to save computation, especially for clients that remember tiles --- at previously seen positions. Similarly, when updating the @lseen@ --- field we don't assume the tiles were unknown previously. +-- Showing to the client the embedded items, if any, is done elsewhere. +updSearchTile :: MonadStateWrite m + => ActorId -> Point -> Kind.Id TileKind -> m () +updSearchTile aid p toTile = do + Kind.COps{cotile} <- getsState scops + b <- getsState $ getActorBody aid + lvl <- getLevel $ blid b + let t = lvl `at` p + if t == toTile + then atomicFail "tile already searched" + else assert (Just t == Tile.hideAs cotile toTile) $ do + updLoseTile (blid b) [(p, t)] + updSpotTile (blid b) [(p, toTile)] -- not the hidden version this one time + +-- Notice previously invisible tiles. This is done in bulk, +-- because it often involves dozens of tiles per move. +-- We verify that the old tiles at the positions in question +-- are indeed unknown. updSpotTile :: MonadStateWrite m => LevelId -> [(Point, Kind.Id TileKind)] -> m () updSpotTile lid ts = assert (not $ null ts) $ do Kind.COps{coTileSpeedup} <- getsState scops - Level{ltile} <- getLevel lid - let adj tileMap = tileMap PointArray.// ts + let unk tileMap (p, _) = tileMap PointArray.! p == unknownId + adj tileMap = assert (all (unk tileMap) ts) $ tileMap PointArray.// ts updateLevel lid $ updateTile adj - let f (p, t2) = do - let t1 = ltile PointArray.! p - case (Tile.isExplorable coTileSpeedup t1, Tile.isExplorable coTileSpeedup t2) of - (False, True) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl+1} - (True, False) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl-1} - _ -> return () + let f (_, t1) = when (Tile.isExplorable coTileSpeedup t1) $ + updateLevel lid $ \lvl -> lvl {lseen = lseen lvl + 1} mapM_ f ts --- Stop noticing previously visible tiles. Unlike @updSpotActor@, it verifies --- the state of the tiles before changing them. +-- Stop noticing previously visible tiles. It verifies +-- the state of the tiles before wiping them out. updLoseTile :: MonadStateWrite m => LevelId -> [(Point, Kind.Id TileKind)] -> m () updLoseTile lid ts = assert (not $ null ts) $ do Kind.COps{coTileSpeedup} <- getsState scops - let matches _ [] = True - matches tileMap ((p, ov) : rest) = - tileMap PointArray.! p == ov && matches tileMap rest + let matches tileMap (p, ov) = tileMap PointArray.! p == ov tu = map (second (const unknownId)) ts - adj tileMap = assert (matches tileMap ts) $ tileMap PointArray.// tu + adj tileMap = assert (all (matches tileMap) ts) $ tileMap PointArray.// tu updateLevel lid $ updateTile adj - let f (_, t1) = - when (Tile.isExplorable coTileSpeedup t1) $ - updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1} + let f (_, t1) = when (Tile.isExplorable coTileSpeedup t1) $ + updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1} mapM_ f ts updAlterSmell :: MonadStateWrite m => LevelId -> Point -> Time -> Time -> m () @@ -466,7 +530,6 @@ insertItemContainer iid (k, toIt) c Nothing -> error $ "" `showFailure` (bag, iid, c, fromIt, toIt) --- | Age the game. updAgeGame :: MonadStateWrite m => [LevelId] -> m () updAgeGame lids = do modifyState $ updateTime $ flip timeShift (Delta timeClip) @@ -480,6 +543,104 @@ ageLevel :: MonadStateWrite m => Delta Time -> LevelId -> m () ageLevel delta lid = updateLevel lid $ \lvl -> lvl {ltime = timeShift (ltime lvl) delta} + +updDiscover :: MonadStateWrite m + => Container -> ItemId -> Kind.Id ItemKind -> ItemSeed -> m () +updDiscover _c iid ik seed = do + itemD <- getsState sitemD + case EM.lookup iid itemD of + Nothing -> atomicFail "discovered item unknown" + Just item -> do + discoKind <- getsState sdiscoKind + case EM.lookup (jkindIx item) discoKind of + Just KindMean{kmConst} -> do + discoAspect <- getsState sdiscoAspect + if kmConst || iid `EM.member` discoAspect + then atomicFail "item already fully discovered" + else discoverSeed iid seed + Nothing -> do + KindMean{kmConst} <- discoverKind (jkindIx item) ik + unless kmConst $ discoverSeed iid seed + resetActorAspect + +updCover :: Container -> ItemId -> Kind.Id ItemKind -> ItemSeed -> m () +updCover _c _iid _ik _seed = undefined + +updDiscoverKind :: MonadStateWrite m + => Container -> ItemKindIx -> Kind.Id ItemKind -> m () +updDiscoverKind _c ix kmKind = do + discoKind <- getsState sdiscoKind + if ix `EM.member` discoKind + then atomicFail "item kind already discovered" + else do + void $ discoverKind ix kmKind + resetActorAspect + +discoverKind :: MonadStateWrite m + => ItemKindIx -> Kind.Id ItemKind -> m KindMean +discoverKind ix kmKind = do + Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops + let kind = okind kmKind + kmMean = meanAspect kind + kmConst = not $ aspectsRandom kind + km = KindMean{..} + f Nothing = Just km + f Just{} = error $ "already discovered" `showFailure` (ix, kmKind) + modifyState $ updateDiscoKind $ \discoKind1 -> + EM.alter f ix discoKind1 + return km + +updCoverKind :: Container -> ItemKindIx -> Kind.Id ItemKind -> m () +updCoverKind _c _ix _ik = undefined + +updDiscoverSeed :: MonadStateWrite m + => Container -> ItemId -> ItemSeed -> m () +updDiscoverSeed _c iid seed = do + itemD <- getsState sitemD + case EM.lookup iid itemD of + Nothing -> atomicFail "discovered item unknown" + Just item -> do + discoKind <- getsState sdiscoKind + case EM.lookup (jkindIx item) discoKind of + Nothing -> error "discovered item kind unknown" + Just KindMean{kmConst} -> do + discoAspect <- getsState sdiscoAspect + if kmConst || iid `EM.member` discoAspect + then atomicFail "item seed already discovered" + else do + discoverSeed iid seed + resetActorAspect + +discoverSeed :: MonadStateWrite m => ItemId -> ItemSeed -> m () +discoverSeed iid seed = do + Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops + item <- getsState $ getItemBody iid + totalDepth <- getsState stotalDepth + Level{ldepth} <- getLevel $ jlid item + discoKind <- getsState sdiscoKind + let KindMean{..} = fromMaybe (error "discovered item kind unknown") + (EM.lookup (jkindIx item) discoKind) + kind = okind kmKind + aspects = seedToAspect seed kind ldepth totalDepth + f Nothing = Just aspects + f Just{} = error $ "already discovered" `showFailure` (iid, seed) + assert (not kmConst) $ + modifyState $ updateDiscoAspect $ \discoAspect1 -> + EM.alter f iid discoAspect1 + +updCoverSeed :: Container -> ItemId -> ItemSeed -> m () +updCoverSeed _c _iid _seed = undefined + +updDiscoverServer :: MonadStateWrite m => ItemId -> AspectRecord -> m () +updDiscoverServer iid aspectRecord = + modifyState $ updateDiscoAspect $ \discoAspect1 -> + EM.insert iid aspectRecord discoAspect1 + +updCoverServer :: MonadStateWrite m => ItemId -> AspectRecord -> m () +updCoverServer iid aspectRecord = + modifyState $ updateDiscoAspect $ \discoAspect1 -> + assert (discoAspect1 EM.! iid == aspectRecord) + $ EM.delete iid discoAspect1 updRestart :: MonadStateWrite m => State -> m () updRestart = putState diff --git a/Game/LambdaHack/Atomic/MonadAtomic.hs b/Game/LambdaHack/Atomic/MonadAtomic.hs deleted file mode 100644 --- a/Game/LambdaHack/Atomic/MonadAtomic.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | Atomic monads for handling atomic game state transformations. -module Game.LambdaHack.Atomic.MonadAtomic - ( MonadAtomic(..) - ) where - -import Prelude () - -import Game.LambdaHack.Atomic.CmdAtomic -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Perception - --- | The monad for executing atomic game state transformations. -class MonadStateRead m => MonadAtomic m where - -- | Execute an atomic command that really changes the state. - execUpdAtomic :: UpdAtomic -> m () - -- | Execute an atomic command that only displays special effects. - execSfxAtomic :: SfxAtomic -> m () - execSendPer :: FactionId -> LevelId - -> Perception -> Perception -> Perception -> m () diff --git a/Game/LambdaHack/Atomic/MonadStateWrite.hs b/Game/LambdaHack/Atomic/MonadStateWrite.hs --- a/Game/LambdaHack/Atomic/MonadStateWrite.hs +++ b/Game/LambdaHack/Atomic/MonadStateWrite.hs @@ -1,17 +1,27 @@ --- | The monad for writing to the game state and related operations. +-- | The monad for writing to the main game state. module Game.LambdaHack.Atomic.MonadStateWrite - ( MonadStateWrite(..) - , putState, updateLevel, updateActor, updateFaction - , insertItemContainer, insertItemActor, deleteItemContainer, deleteItemActor - , updateFloor, updateActorMap, moveActorMap - , updateTile, updateSmell + ( MonadStateWrite(..), AtomicFail(..), atomicFail + , putState, updateLevel, updateActor, updateFaction, moveActorMap + , insertBagContainer, insertItemContainer, insertItemActor + , deleteBagContainer, deleteItemContainer, deleteItemActor + , addAis, itemsMatch, addItemToActor, resetActorAspect +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , insertItemFloor, insertItemEmbed + , insertItemOrgan, insertItemEqp, insertItemInv, insertItemSha + , deleteItemFloor, deleteItemEmbed + , deleteItemOrgan, deleteItemEqp, deleteItemInv, deleteItemSha + , rmFromBag +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude +import qualified Control.Exception as Ex import qualified Data.EnumMap.Strict as EM +import Data.Key (mapWithKeyM_) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState @@ -23,23 +33,49 @@ import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State +-- | The monad for writing to the main game state. Atomic updates ('UpdAtomic') +-- are given semantics in this monad. class MonadStateRead m => MonadStateWrite m where modifyState :: (State -> State) -> m () +-- | Exception signifying that atomic action failed because +-- the information it carries is inconsistent with the client's state, +-- (e.g., because the client knows too little to understand the command +-- or already deduced the state change from earlier commands +-- or is confused, amnesiac or sees illusory actors or tiles). +-- Whenever we know the failure is logically impossible, +-- we don't throw the @AtomicFail@ exception, but insert a normal assertion +-- or @error@ call, which are never caught nor handled. +newtype AtomicFail = AtomicFail String + deriving Show + +instance Ex.Exception AtomicFail + +atomicFail :: String -> a +atomicFail = Ex.throw . AtomicFail + putState :: MonadStateWrite m => State -> m () putState s = modifyState (const s) --- | Update the items on the ground map. -updateFloor :: (ItemFloor -> ItemFloor) -> Level -> Level -updateFloor f lvl = lvl {lfloor = f (lfloor lvl)} +-- INLIning offers no speedup, increases alloc and binary size. +-- EM.alter not necessary, because levels not removed, so little risk +-- of adjusting at absent index. +updateLevel :: MonadStateWrite m => LevelId -> (Level -> Level) -> m () +updateLevel lid f = modifyState $ updateDungeon $ EM.adjust f lid --- | Update the items embedded in a tile on the level. -updateEmbed :: (ItemFloor -> ItemFloor) -> Level -> Level -updateEmbed f lvl = lvl {lembed = f (lembed lvl)} +-- INLIning doesn't help despite probably canceling the alt indirection. +-- perhaps it's applied automatically due to INLINABLE. +updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m () +updateActor aid f = do + let alt Nothing = error $ "no body to update" `showFailure` aid + alt (Just b) = Just $ f b + modifyState $ updateActorD $ EM.alter alt aid --- | Update the actors on the ground map. -updateActorMap :: (ActorMap -> ActorMap) -> Level -> Level -updateActorMap f lvl = lvl {lactor = f (lactor lvl)} +updateFaction :: MonadStateWrite m => FactionId -> (Faction -> Faction) -> m () +updateFaction fid f = do + let alt Nothing = error $ "no faction to update" `showFailure` fid + alt (Just fact) = Just $ f fact + modifyState $ updateFactionD $ EM.alter alt fid moveActorMap :: MonadStateWrite m => ActorId -> Actor -> Actor -> m () moveActorMap aid body newBody = do @@ -63,34 +99,23 @@ . EM.alter rmActor (bpos body) updateLevel (blid body) $ updateActorMap updActor --- | Update the tile map. -updateTile :: (TileMap -> TileMap) -> Level -> Level -updateTile f lvl = lvl {ltile = f (ltile lvl)} - --- | Update the smell map. -updateSmell :: (SmellMap -> SmellMap) -> Level -> Level -updateSmell f lvl = lvl {lsmell = f (lsmell lvl)} - --- INLIning offers no speedup, increases alloc and binary size. --- EM.alter not necessary, because levels not removed, so little risk --- of adjusting at absent index. --- | Update a given level data within state. -updateLevel :: MonadStateWrite m => LevelId -> (Level -> Level) -> m () -updateLevel lid f = modifyState $ updateDungeon $ EM.adjust f lid - --- INLIning doesn't help despite probably canceling the alt indirection. --- perhaps it's applied automatically due to INLINABLE. -updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m () -updateActor aid f = do - let alt Nothing = error $ "no body to update" `showFailure` aid - alt (Just b) = Just $ f b - modifyState $ updateActorD $ EM.alter alt aid - -updateFaction :: MonadStateWrite m => FactionId -> (Faction -> Faction) -> m () -updateFaction fid f = do - let alt Nothing = error $ "no faction to update" `showFailure` fid - alt (Just fact) = Just $ f fact - modifyState $ updateFactionD $ EM.alter alt fid +insertBagContainer :: MonadStateWrite m + => ItemBag -> Container -> m () +insertBagContainer bag c = case c of + CFloor lid pos -> do + let alt Nothing = Just bag + alt (Just bag2) = atomicFail $ "floor bag not empty" + `showFailure` (bag2, lid, pos, bag) + updateLevel lid $ updateFloor $ EM.alter alt pos + CEmbed lid pos -> do + let alt Nothing = Just bag + alt (Just bag2) = atomicFail $ "embed bag not empty" + `showFailure` (bag2, lid, pos, bag) + updateLevel lid $ updateEmbed $ EM.alter alt pos + CActor aid store -> + -- Very unlikely case, so we prefer brevity over performance. + mapWithKeyM_ (\iid kit -> insertItemActor iid kit aid store) bag + CTrunk{} -> return () insertItemContainer :: MonadStateWrite m => ItemId -> ItemQuant -> Container -> m () @@ -162,6 +187,24 @@ upd = EM.unionWith mergeItemQuant bag updateFaction fid $ \fact -> fact {gsha = upd (gsha fact)} +deleteBagContainer :: MonadStateWrite m + => ItemBag -> Container -> m () +deleteBagContainer bag c = case c of + CFloor lid pos -> do + let alt Nothing = atomicFail $ "floor bag already empty" + `showFailure` (lid, pos, bag) + alt (Just bag2) = assert (bag == bag2) Nothing + updateLevel lid $ updateFloor $ EM.alter alt pos + CEmbed lid pos -> do + let alt Nothing = atomicFail $ "embed bag already empty" + `showFailure` (lid, pos, bag) + alt (Just bag2) = assert (bag == bag2 `blame` (bag, bag2)) Nothing + updateLevel lid $ updateEmbed $ EM.alter alt pos + CActor aid store -> + -- Very unlikely case, so we prefer brevity over performance. + mapWithKeyM_ (\iid kit -> deleteItemActor iid kit aid store) bag + CTrunk{} -> error $ "" `showFailure` c + deleteItemContainer :: MonadStateWrite m => ItemId -> ItemQuant -> Container -> m () deleteItemContainer iid kit c = case c of @@ -239,3 +282,42 @@ `blame` (rmIt, take k it, n, kit, iid, bag)) $ Just (n - k, take (n - k) it) in EM.alter rfb iid bag + +-- Actor's items may or may not be already present in @sitemD@, +-- regardless if they are already present otherwise in the dungeon. +-- We re-add them all to save time determining which really need it. +-- If collision occurs, pick the item found on easier level. +addAis :: MonadStateWrite m => [(ItemId, Item)] -> m () +addAis ais = do + let h item1 item2 = + assert (itemsMatch item1 item2 + `blame` "inconsistent added items" + `swith` (item1, item2, ais)) + item2 -- keep the first found level + forM_ ais $ \(iid, item) -> + modifyState + $ updateItemIxMap (EM.insertWith (++) (jkindIx item) [iid]) + . updateItemD (EM.insertWith h iid item) + +itemsMatch :: Item -> Item -> Bool +itemsMatch item1 item2 = + jkindIx item1 == jkindIx item2 + -- Note that nothing else needs to be the same, since items are merged + -- and clients have different views on dungeon items than the server. + +addItemToActor :: MonadStateWrite m => ItemId -> Item -> Int -> ActorId -> m () +addItemToActor iid itemBase k aid = do + arItem <- getsState $ aspectRecordFromItem iid itemBase + let f arActor = sumAspectRecord [(arActor, 1), (arItem, k)] + modifyState $ updateActorAspect $ EM.adjust f aid + +resetActorAspect :: MonadStateWrite m => m () +resetActorAspect = do + -- Each actor's equipment and organs would need to be inspected, + -- the iid looked up, e.g., if it wasn't in old discoKind, but is in new, + -- and then aspect record updated, so it's simpler and not much more + -- expensive to generate new sactorAspect. Optimize only after profiling. + -- Also note this doesn't get invoked on the server, because it bails out + -- earlier, upon noticing the item is already fully known. + actorAspect <- getsState actorAspectInDungeon + modifyState $ updateActorAspect $ const actorAspect diff --git a/Game/LambdaHack/Atomic/PosAtomicRead.hs b/Game/LambdaHack/Atomic/PosAtomicRead.hs --- a/Game/LambdaHack/Atomic/PosAtomicRead.hs +++ b/Game/LambdaHack/Atomic/PosAtomicRead.hs @@ -1,23 +1,27 @@ --- | Semantics of atomic commands shared by client and server. +-- | Representation and computation of visiblity of atomic commands +-- by clients. +-- -- See -- . module Game.LambdaHack.Atomic.PosAtomicRead ( PosAtomic(..), posUpdAtomic, posSfxAtomic - , breakUpdAtomic, seenAtomicCli, seenAtomicSer, generalMoveItem, posProjBody + , breakUpdAtomic, seenAtomicCli, seenAtomicSer +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , posProjBody, singleAid, doubleAid, singleContainer +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead @@ -35,29 +39,35 @@ | PosFidAndSight [FactionId] LevelId [Point] -- ^ observers and the faction notice | PosSmell LevelId [Point] -- ^ whomever smells all the positions, notices - | PosFid FactionId -- ^ only the faction notices - | PosFidAndSer (Maybe LevelId) FactionId -- ^ faction and server notices + | PosFid FactionId -- ^ only the faction notices, server doesn't + | PosFidAndSer (Maybe LevelId) FactionId + -- ^ faction and server notices | PosSer -- ^ only the server notices | PosAll -- ^ everybody notices | PosNone -- ^ never broadcasted, but sent manually deriving (Show, Eq) --- | Produce the positions where the atomic update takes place. +-- | Produce the positions where the atomic update takes place or, more +-- generally, the conditions under which the update can be noticed by +-- a client. -- --- The goal of the mechanics is to ensure the commands don't carry --- significantly more information than their corresponding state diffs would. --- In other words, the atomic commands involving the positions seen by a client --- should convey similar information as the client would get by directly --- observing the changes the commands enact on the visible portion of server --- game state. The client is then free to change its copy of game state --- accordingly or not --- it only partially reflects reality anyway. +-- The goal of this mechanics is to ensure that atomic commands involving +-- some positions visible by a client convey similar information as the client +-- would get by directly observing the changes +-- of the portion of server state limited to the visible positions. +-- Consequently, when the visible commands are later applied +-- to the client's state, the state stays consistent +-- --- in sync with the server state and correctly limited by visiblity. +-- There is some wiggle room both in what "in sync" and +-- "visible" means and how they propagate through time. -- --- E.g., @UpdDisplaceActor@ in a black room, --- with one actor carrying a 0-radius light would not be +-- E.g., @UpdDisplaceActor@ in a black room between two enemy actors, +-- with only one actor carrying a 0-radius light would not be -- distinguishable by looking at the state (or the screen) from @UpdMoveActor@ -- of the illuminated actor, hence such @UpdDisplaceActor@ should not be --- observable, but @UpdMoveActor@ should be (or the former should be perceived --- as the latter). However, to simplify, we assign as strict visibility +-- observable, but @UpdMoveActor@ in similar cotext would be +-- (or the former should be perceived as the latter). +-- However, to simplify, we assign as strict visibility -- requirements to @UpdMoveActor@ as to @UpdDisplaceActor@ and fall back -- to @UpdSpotActor@ (which provides minimal information that does not -- contradict state) if the visibility is lower. @@ -71,6 +81,8 @@ UpdLoseActor _ body _ -> return $! posProjBody body UpdSpotItem _ _ _ _ c -> singleContainer c UpdLoseItem _ _ _ _ c -> singleContainer c + UpdSpotItemBag c _ _ -> singleContainer c + UpdLoseItemBag c _ _ -> singleContainer c UpdMoveActor aid fromP toP -> do b <- getsState $ getActorBody aid -- Non-projectile actors are never totally isolated from envirnoment; @@ -125,14 +137,15 @@ UpdCoverKind c _ _ -> singleContainer c UpdDiscoverSeed c _ _ -> singleContainer c UpdCoverSeed c _ _ -> singleContainer c + UpdDiscoverServer{} -> return PosSer + UpdCoverServer{} -> return PosSer UpdPerception{} -> return PosNone - UpdRestart fid _ _ _ _ _ -> return $! PosFid fid + UpdRestart fid _ _ _ _ -> return $! PosFid fid UpdRestartServer _ -> return PosSer UpdResume _ _ -> return PosNone UpdResumeServer _ -> return PosSer UpdKillExit fid -> return $! PosFid fid UpdWriteSave -> return PosAll - UpdMsgAll{} -> return PosAll -- | Produce the positions where the atomic special effect takes place. posSfxAtomic :: MonadStateRead m => SfxAtomic -> m PosAtomic @@ -161,6 +174,7 @@ else return $! PosFidAndSight [bfid body] (blid body) [bpos body, p] SfxEffect _ aid _ _ -> singleAid aid -- sometimes we don't see source, OK SfxMsgFid fid _ -> return $! PosFid fid + SfxSortSlots -> return PosAll posProjBody :: Actor -> PosAtomic posProjBody body = @@ -191,23 +205,25 @@ singleContainer (CTrunk fid lid p) = return $! PosFidAndSight [fid] lid [p] --- | Decompose an atomic action. The decomposed actions give reduced --- information that still modifies client's state to match the server state --- wrt the current FOV and the subset of @posUpdAtomic@ that is visible. --- The original actions give more information not only due to spanning --- potentially more positions than those visible. E.g., @UpdMoveActor@ +-- | Decompose an atomic action that is outside a client's visiblity. +-- The decomposed actions give less information that the original command, +-- but some of them may fall within the visibility range of the client. +-- The original action may give more information than even the total sum +-- of all actions it's broken into. E.g., @UpdMoveActor@ -- informs about the continued existence of the actor between --- moves, v.s., popping out of existence and then back in. +-- moves vs popping out of existence and then back in. +-- +-- This is computed in server's @State@ from before performing the command. breakUpdAtomic :: MonadStateRead m => UpdAtomic -> m [UpdAtomic] breakUpdAtomic cmd = case cmd of - UpdMoveActor aid _ toP -> do + UpdMoveActor aid fromP toP -> do -- We assume other factions don't see leaders and we know the actor's -- faction always sees the atomic command, so the leader doesn't -- need to be updated (or the actor is a projectile, hence not a leader). b <- getsState $ getActorBody aid ais <- getsState $ getCarriedAssocs b return [ UpdLoseActor aid b ais - , UpdSpotActor aid b {bpos = toP, boldpos = Just $ bpos b} ais ] + , UpdSpotActor aid b {bpos = toP, boldpos = Just fromP} ais ] UpdDisplaceActor source target -> do sb <- getsState $ getActorBody source sais <- getsState $ getCarriedAssocs sb @@ -222,7 +238,7 @@ ] _ -> return [] --- | Given the client, it's perception and an atomic command, determine +-- | Given the client, its perception and an atomic command, determine -- if the client notices the command. seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool seenAtomicCli knowEvents fid per posAtomic = @@ -237,34 +253,11 @@ PosAll -> True PosNone -> error $ "no position possible" `showFailure` fid --- Not needed ATM, but may be a coincidence. +-- | Determine whether the server would see a command that has +-- the given visibilty conditions. seenAtomicSer :: PosAtomic -> Bool seenAtomicSer posAtomic = case posAtomic of PosFid _ -> False PosNone -> error $ "no position possible" `showFailure` posAtomic _ -> True - --- | Generate the atomic updates that jointly perform a given item move. -generalMoveItem :: MonadStateRead m - => Bool -> ItemId -> Int -> Container -> Container - -> m [UpdAtomic] -generalMoveItem verbose iid k c1 c2 = - case (c1, c2) of - (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2 - && cstore1 /= CSha - && cstore2 /= CSha -> - return [UpdMoveItem iid k aid1 cstore1 cstore2] - _ -> containerMoveItem verbose iid k c1 c2 - -containerMoveItem :: MonadStateRead m - => Bool -> ItemId -> Int -> Container -> Container - -> m [UpdAtomic] -containerMoveItem verbose iid k c1 c2 = do - bag <- getsState $ getContainerBag c1 - case iid `EM.lookup` bag of - Nothing -> error $ "" `showFailure` (iid, k, c1, c2) - Just (_, it) -> do - item <- getsState $ getItemBody iid - return [ UpdLoseItem verbose iid item (k, take k it) c1 - , UpdSpotItem verbose iid item (k, take k it) c2 ] diff --git a/Game/LambdaHack/Client.hs b/Game/LambdaHack/Client.hs --- a/Game/LambdaHack/Client.hs +++ b/Game/LambdaHack/Client.hs @@ -1,16 +1,29 @@ --- | Semantics of responses that are sent to clients. +-- | Semantics of responses that are sent from server to clients, +-- in terms of client state transformations, +-- and semantics of human commands and AI moves, in terms of requests +-- to be sent from the client to the server. -- -- See -- . module Game.LambdaHack.Client ( -- * Re-exported from "Game.LambdaHack.Client.LoopM" loopCli + -- * Re-exported from "Game.LambdaHack.Client.Request" + , RequestAI, ReqAI(..), RequestUI, ReqUI(..) + , RequestAnyAbility(..), RequestTimed(..) + -- * Re-exported from "Game.LambdaHack.Client.Response" + , Response (..) + -- * Re-exported from "Game.LambdaHack.Client.ClientOptions" + , ClientOptions, defClientOptions, sbenchmark -- * Re-exported from "Game.LambdaHack.Client.UI" - , KeyKind, SessionUI, emptySessionUI - , Config, applyConfigToDebug, configCmdline, mkConfig + , KeyKind + , UIOptions, applyUIOptions, uCmdline, mkUIOptions ) where import Prelude () +import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.LoopM +import Game.LambdaHack.Client.Request +import Game.LambdaHack.Client.Response import Game.LambdaHack.Client.UI diff --git a/Game/LambdaHack/Client/AI.hs b/Game/LambdaHack/Client/AI.hs --- a/Game/LambdaHack/Client/AI.hs +++ b/Game/LambdaHack/Client/AI.hs @@ -5,7 +5,7 @@ ( queryAI #ifdef EXPOSE_INTERNAL -- * Internal operations - , pickAI, pickAction, udpdateCondInMelee, condInMeleeM + , pickActorAndAction, udpdateCondInMelee #endif ) where @@ -17,57 +17,56 @@ import Game.LambdaHack.Client.AI.HandleAbilityM import Game.LambdaHack.Client.AI.PickActorM -import Game.LambdaHack.Client.AI.Strategy import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.Request import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State --- | Handle the move of an actor under AI control (of UI or AI player). +-- | Handle the move of an actor under AI control (regardless if the whole +-- faction is under human or computer control). queryAI :: MonadClient m => ActorId -> m RequestAI queryAI aid = do - -- @_sleader@ may be different from @_gleader@ due to @stopPlayBack@, + -- @sleader@ may be different from @gleader@ due to @stopPlayBack@, -- but only leaders may change faction leader, so we fix that: side <- getsClient sside - mleader <- getsState $ _gleader . (EM.! side) . sfactionD - mleaderCli <- getsClient _sleader + mleader <- getsState $ gleader . (EM.! side) . sfactionD + mleaderCli <- getsClient sleader unless (Just aid == mleader || mleader == mleaderCli) $ -- @aid@ is not the leader, so he can't change leader modifyClient $ \cli -> cli {_sleader = mleader} - -- @condInMelee@ will most proably be needed in this functions, + -- @condInMelee@ will most proably be needed in the following functions, -- but even if not, it's OK, it's not forced, because wrapped in @Maybe@: udpdateCondInMelee aid - (aidToMove, treq) <- pickAI Nothing aid + (aidToMove, treq) <- pickActorAndAction Nothing aid (aidToMove2, treq2) <- case treq of RequestAnyAbility ReqWait | mleader == Just aid -> do -- leader waits; a waste; try once to pick a yet different leader modifyClient $ \cli -> cli {_sleader = mleader} -- undo previous choice - pickAI (Just (aidToMove, treq)) aid + pickActorAndAction (Just (aidToMove, treq)) aid _ -> return (aidToMove, treq) return ( ReqAITimed treq2 , if aidToMove2 /= aid then Just aidToMove2 else Nothing ) -pickAI :: MonadClient m - => Maybe (ActorId, RequestAnyAbility) -> ActorId - -> m (ActorId, RequestAnyAbility) +-- | Pick an actor to move and an action for him to perform, given an optional +-- previous candidate actor and action and the server-proposed actor. +pickActorAndAction :: MonadClient m + => Maybe (ActorId, RequestAnyAbility) -> ActorId + -> m (ActorId, RequestAnyAbility) -- This inline speeds up execution by 10% and increases allocation by 15%, -- despite probably bloating executable: -{-# INLINE pickAI #-} -pickAI maid aid = do - mleader <- getsClient _sleader +{-# INLINE pickActorAndAction #-} +pickActorAndAction maid aid = do + mleader <- getsClient sleader aidToMove <- if mleader == Just aid then pickActorToMove (fst <$> maid) else do - useTactics aid + setTargetFromTactics aid return aid treq <- case maid of Just (aidOld, treqOld) | aidToMove == aidOld -> @@ -75,26 +74,11 @@ _ -> pickAction aidToMove (isJust maid) return (aidToMove, treq) --- | Pick an action the actor will perform this turn. -pickAction :: MonadClient m => ActorId -> Bool -> m RequestAnyAbility -{-# INLINE pickAction #-} -pickAction aid retry = do - side <- getsClient sside - body <- getsState $ getActorBody aid - let !_A = assert (bfid body == side - `blame` "AI tries to move enemy actor" - `swith` (aid, bfid body, side)) () - let !_A = assert (isNothing (btrajectory body) - `blame` "AI gets to manually move its projectiles" - `swith` (aid, bfid body, side)) () - stratAction <- actionStrategy aid retry - let bestAction = bestVariant stratAction - !_A = assert (not (nullFreq bestAction) -- equiv to nullStrategy - `blame` "no AI action for actor" - `swith` (stratAction, aid, body)) () - -- Run the AI: chose an action from those given by the AI strategy. - rndToAction $ frequency bestAction - +-- | Check if any non-dying foe (projectile or not) is adjacent +-- to any of our normal actors (whether they can melee or just need to flee, +-- in which case alert is needed so that they are not slowed down by others) +-- and record this per-level. This is needed only by AI and computed +-- as lazily as possible before each round of AI deliberations. udpdateCondInMelee :: MonadClient m => ActorId -> m () udpdateCondInMelee aid = do b <- getsState $ getActorBody aid @@ -102,26 +86,8 @@ case condInMelee of Just{} -> return () -- still up to date Nothing -> do - newCond <- condInMeleeM b -- lazy and kept that way due to @Maybe@ + newCond <- getsState $ inMelee b + -- lazy and kept that way due to @Maybe@ modifyClient $ \cli -> cli {scondInMelee = EM.adjust (const $ Just newCond) (blid b) (scondInMelee cli)} - --- | Check if any non-dying foe (projectile or not) is adjacent --- to any of our normal actors (whether they can melee or just need to flee, --- in which case alert is needed so that they are not slowed down by others). -condInMeleeM :: MonadClient m => Actor -> m Bool -condInMeleeM bodyOur = do - fact <- getsState $ (EM.! bfid bodyOur) . sfactionD - let f !b = blid b == blid bodyOur && isAtWar fact (bfid b) && bhp b > 0 - -- We assume foes are less numerous, because usually they are heroes, - -- and so we compute them once and use many times. - -- For the same reason @anyFoeAdj@ would not speed up this computation - -- in normal gameplay (as opposed to AI vs AI benchmarks). - allFoes <- getsState $ filter f . EM.elems . sactorD - getsState $ any (\body -> - bfid bodyOur == bfid body - && blid bodyOur == blid body - && not (bproj body) - && bhp body > 0 - && any (\b -> adjacent (bpos b) (bpos body)) allFoes) . sactorD diff --git a/Game/LambdaHack/Client/AI/ConditionM.hs b/Game/LambdaHack/Client/AI/ConditionM.hs --- a/Game/LambdaHack/Client/AI/ConditionM.hs +++ b/Game/LambdaHack/Client/AI/ConditionM.hs @@ -1,23 +1,22 @@ --- | Semantics of abilities in terms of actions and the AI procedure --- for picking the best action for an actor. +-- | Assorted conditions used later on in AI logic. module Game.LambdaHack.Client.AI.ConditionM ( condAimEnemyPresentM , condAimEnemyRememberedM , condTgtNonmovingM , condAnyFoeAdjM , condAdjTriggerableM + , meleeThreatDistList , condBlocksFriendsM , condFloorWeaponM , condNoEqpWeaponM , condCanProjectM , condProjectListM - , condDesirableFloorItemM - , condSupport , benAvailableItems , hinders + , condDesirableFloorItemM , benGroundItems , desirableItem - , meleeThreatDistList + , condSupport , condShineWouldBetrayM , fleeList ) where @@ -27,29 +26,29 @@ import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM -import Data.Ord +import Data.Ord -import Game.LambdaHack.Client.Bfs -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.Bfs +import Game.LambdaHack.Client.CommonM +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State import qualified Game.LambdaHack.Common.Ability as Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.ModeKind -- All conditions are (partially) lazy, because they are not always -- used in the strict monadic computations they are in. @@ -103,9 +102,10 @@ -- so to resolve the stalemate, the opposing AI has to be aggresive -- by ignoring them and then when melee is started, it's usually too late -- to retreat. -meleeThreatDistList :: MonadClient m => ActorId -> m [(Int, (ActorId, Actor))] +meleeThreatDistList :: MonadStateRead m + => ActorId -> m [(Int, (ActorId, Actor))] meleeThreatDistList aid = do - actorAspect <- getsClient sactorAspect + actorAspect <- getsState sactorAspect b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD allAtWar <- getsState $ actorRegularAssocs (isAtWar fact) (blid b) @@ -132,14 +132,14 @@ return $ any blocked ours -- | Require the actor stands over a weapon that would be auto-equipped. -condFloorWeaponM :: MonadClient m => ActorId -> m Bool +condFloorWeaponM :: MonadStateRead m => ActorId -> m Bool condFloorWeaponM aid = do floorAssocs <- getsState $ getActorAssocs aid CGround let lootIsWeapon = any (isMelee . snd) floorAssocs return lootIsWeapon -- | Check whether the actor has no weapon in equipment. -condNoEqpWeaponM :: MonadClient m => ActorId -> m Bool +condNoEqpWeaponM :: MonadStateRead m => ActorId -> m Bool condNoEqpWeaponM aid = do eqpAssocs <- getsState $ getActorAssocs aid CEqp return $ all (not . isMelee . snd) eqpAssocs @@ -159,9 +159,8 @@ b <- getsState $ getActorBody aid condShineWouldBetray <- condShineWouldBetrayM aid condAimEnemyPresent <- condAimEnemyPresentM aid - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) - calmE = calmEnough b ar + ar <- getsState $ getActorAspect aid + let calmE = calmEnough b ar condNotCalmEnough = not calmE heavilyDistressed = -- Actor hit by a projectile or similarly distressed. deltaSerious (bcalmDelta b) @@ -186,7 +185,7 @@ => ActorId -> [CStore] -> m [(Maybe Benefit, CStore, ItemId, ItemFull)] benAvailableItems aid cstores = do - itemToF <- itemToFullClient + itemToF <- getsState itemToFull b <- getsState $ getActorBody aid discoBenefit <- getsClient sdiscoBenefit s <- getState @@ -238,7 +237,7 @@ benList <- benAvailableItems aid [CGround] return $ filter isDesirable benList -desirableItem :: Bool -> Maybe Int -> Item -> Bool +desirableItem :: Bool -> Maybe Double -> Item -> Bool desirableItem canEsc mpickupSum item = if canEsc then fromMaybe 10 mpickupSum > 0 @@ -253,7 +252,7 @@ condSupport :: MonadClient m => Int -> ActorId -> m Bool condSupport param aid = do - actorAspect <- getsClient sactorAspect + actorAspect <- getsState sactorAspect b <- getsState $ getActorBody aid btarget <- getsClient $ getTarget aid mtgtPos <- case btarget of @@ -274,14 +273,14 @@ closeAndStrong (aid2, b2) = closeEnough b2 && actorCanMelee actorAspect aid2 b2 closeAndStrongFriends = filter closeAndStrong friends - -- The smaller area scanned for friends, the lower number required. - suport = length closeAndStrongFriends >= param - aAggression ar + -- The smaller the area scanned for friends, the lower number required. + suport = length closeAndStrongFriends >= min 2 param - aAggression ar || length friends <= 1 -- solo fighters aggresive return suport -- | Require that the actor stands in the dark and so would be betrayed -- by his own equipped light, -condShineWouldBetrayM :: MonadClient m => ActorId -> m Bool +condShineWouldBetrayM :: MonadStateRead m => ActorId -> m Bool condShineWouldBetrayM aid = do b <- getsState $ getActorBody aid aInAmbient <- getsState $ actorInAmbient b diff --git a/Game/LambdaHack/Client/AI/HandleAbilityM.hs b/Game/LambdaHack/Client/AI/HandleAbilityM.hs --- a/Game/LambdaHack/Client/AI/HandleAbilityM.hs +++ b/Game/LambdaHack/Client/AI/HandleAbilityM.hs @@ -1,14 +1,13 @@ {-# LANGUAGE DataKinds #-} --- | Semantics of abilities in terms of actions and the AI procedure --- for picking the best action for an actor. +-- | AI procedure for picking the best action for an actor. module Game.LambdaHack.Client.AI.HandleAbilityM - ( actionStrategy + ( pickAction #ifdef EXPOSE_INTERNAL -- * Internal operations - , ApplyItemGroup + , actionStrategy , waitBlockNow, pickup, equipItems, toShare, yieldUnneeded, unEquipItems , groupByEqpSlot, bestByEqpSlot, harmful, meleeBlocker, meleeAny - , trigger, projectItem, applyItem, flee + , trigger, projectItem, ApplyItemGroup, applyItem, flee , displaceFoe, displaceBlocker, displaceTowards , chase, moveTowards, moveOrRunAid #endif @@ -20,44 +19,66 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Function -import Data.Ord -import Data.Ratio +import Data.Function +import Data.Ord +import Data.Ratio -import Game.LambdaHack.Client.AI.ConditionM -import Game.LambdaHack.Client.AI.Strategy -import Game.LambdaHack.Client.Bfs -import Game.LambdaHack.Client.BfsM -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Common.Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Frequency -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemStrongest +import Game.LambdaHack.Client.AI.ConditionM +import Game.LambdaHack.Client.AI.Strategy +import Game.LambdaHack.Client.Bfs +import Game.LambdaHack.Client.BfsM +import Game.LambdaHack.Client.CommonM +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.Request +import Game.LambdaHack.Client.State +import Game.LambdaHack.Common.Ability +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Frequency +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.ModeKind +-- | Pick the most desirable AI ation for the actor. +pickAction :: MonadClient m => ActorId -> Bool -> m RequestAnyAbility +{-# INLINE pickAction #-} +pickAction aid retry = do + side <- getsClient sside + body <- getsState $ getActorBody aid + let !_A = assert (bfid body == side + `blame` "AI tries to move enemy actor" + `swith` (aid, bfid body, side)) () + let !_A = assert (isNothing (btrajectory body) + `blame` "AI gets to manually move its projectiles" + `swith` (aid, bfid body, side)) () + stratAction <- actionStrategy aid retry + let bestAction = bestVariant stratAction + !_A = assert (not (nullFreq bestAction) -- equiv to nullStrategy + `blame` "no AI action for actor" + `swith` (stratAction, aid, body)) () + -- Run the AI: chose an action from those given by the AI strategy. + rndToAction $ frequency bestAction + type ToAny a = Strategy (RequestTimed a) -> Strategy RequestAnyAbility toAny :: ToAny a toAny strat = RequestAnyAbility <$> strat --- | AI strategy based on actor's sight, smell, etc. +-- AI strategy based on actor's sight, smell, etc. -- Never empty. actionStrategy :: forall m. MonadClient m => ActorId -> Bool -> m (Strategy RequestAnyAbility) @@ -73,7 +94,7 @@ threatDistL <- meleeThreatDistList aid (fleeL, badVic) <- fleeList aid condSupport1 <- condSupport 1 aid - condSupport2 <- condSupport 2 aid + condSupport3 <- condSupport 3 aid canDeAmbientL <- getsState $ canDeAmbientList body actorSk <- currentSkillsClient aid condCanProject <- @@ -86,8 +107,8 @@ condDesirableFloorItem <- condDesirableFloorItemM aid condTgtNonmoving <- condTgtNonmovingM aid explored <- getsClient sexplored - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) + actorAspect <- getsState sactorAspect + let ar = actorAspect EM.! aid lidExplored = ES.member (blid body) explored panicFleeL = fleeL ++ badVic condHpTooLow = hpTooLow body ar @@ -95,7 +116,6 @@ speed1_5 = speedScale (3%2) (bspeed body ar) condCanMelee = actorCanMelee actorAspect aid body condMeleeBad1 = not (condSupport1 && condCanMelee) - condMeleeBad2 = not (condSupport2 && condCanMelee) condThreat n = not $ null $ takeWhile ((<= n) . fst) threatDistL threatAdj = takeWhile ((== 1) . fst) threatDistL condManyThreatAdj = length threatAdj >= 2 @@ -134,7 +154,7 @@ -- in the latter case, may return via different stairs later on , condAdjTriggerable && not condAimEnemyPresent && ((condNotCalmEnough || condHpTooLow) -- flee - && condMeleeBad2 && condThreat 1 + && condMeleeBad1 && condThreat 1 || (lidExplored || condEnoughGear) -- explore && not condDesirableFloorItem) ) , ( [AbDisplace] @@ -163,7 +183,7 @@ -- to enemy to get out of his range, most likely, -- and so melee him instead, unless can't melee at all. not condCanMelee - || not condSupport2 && not heavilyDistressed + || not condSupport3 && not heavilyDistressed | condThreat 5 -> -- Too far to flee from melee, too close from ranged, -- not in ambient, so no point fleeing into dark; advance. @@ -290,7 +310,6 @@ sumFallback <- sumS fallback return $! sumPrefix .| comDistant .| sumSuffix .| sumFallback --- | A strategy to always just wait. waitBlockNow :: MonadClient m => m (Strategy (RequestTimed 'AbWait)) waitBlockNow = return $! returN "wait" ReqWait @@ -306,9 +325,8 @@ -- The calmE is inaccurate also if an item not IDed, but that's intended -- and the server will ignore and warn (and content may avoid that, -- e.g., making all rings identified) - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) - calmE = calmEnough b ar + ar <- getsState $ getActorAspect aid + let calmE = calmEnough b ar isWeapon (_, _, _, itemFull) = isMelee $ itemBase itemFull filterWeapon | onlyWeapon = filter isWeapon | otherwise = id @@ -338,12 +356,11 @@ => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) equipItems aid = do body <- getsState $ getActorBody aid - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) - calmE = calmEnough body ar - eqpAssocs <- fullAssocsClient aid [CEqp] - invAssocs <- fullAssocsClient aid [CInv] - shaAssocs <- fullAssocsClient aid [CSha] + ar <- getsState $ getActorAspect aid + let calmE = calmEnough body ar + eqpAssocs <- getsState $ fullAssocs aid [CEqp] + invAssocs <- getsState $ fullAssocs aid [CInv] + shaAssocs <- getsState $ fullAssocs aid [CSha] condShineWouldBetray <- condShineWouldBetrayM aid condAimEnemyPresent <- condAimEnemyPresentM aid discoBenefit <- getsClient sdiscoBenefit @@ -401,10 +418,9 @@ => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) yieldUnneeded aid = do body <- getsState $ getActorBody aid - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) - calmE = calmEnough body ar - eqpAssocs <- fullAssocsClient aid [CEqp] + ar <- getsState $ getActorAspect aid + let calmE = calmEnough body ar + eqpAssocs <- getsState $ fullAssocs aid [CEqp] condShineWouldBetray <- condShineWouldBetrayM aid condAimEnemyPresent <- condAimEnemyPresentM aid discoBenefit <- getsClient sdiscoBenefit @@ -439,12 +455,11 @@ => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) unEquipItems aid = do body <- getsState $ getActorBody aid - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) - calmE = calmEnough body ar - eqpAssocs <- fullAssocsClient aid [CEqp] - invAssocs <- fullAssocsClient aid [CInv] - shaAssocs <- fullAssocsClient aid [CSha] + ar <- getsState $ getActorAspect aid + let calmE = calmEnough body ar + eqpAssocs <- getsState $ fullAssocs aid [CEqp] + invAssocs <- getsState $ fullAssocs aid [CInv] + shaAssocs <- getsState $ fullAssocs aid [CSha] discoBenefit <- getsClient sdiscoBenefit let improve :: CStore -> ( IK.EqpSlot , ( [(Int, (ItemId, ItemFull))] @@ -533,8 +548,8 @@ meleeBlocker :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMelee)) meleeBlocker aid = do b <- getsState $ getActorBody aid - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) + actorAspect <- getsState sactorAspect + let ar = actorAspect EM.! aid fact <- getsState $ (EM.! bfid b) . sfactionD actorSk <- currentSkillsClient aid mtgtMPath <- getsClient $ EM.lookup aid . stargetD @@ -553,8 +568,7 @@ Just aim -> getsState $ posToAssocs aim (blid b) case lBlocker of (aid2, body2) : _ -> do - let ar2 = fromMaybe (error $ "" `showFailure` aid2) - (EM.lookup aid2 actorAspect) + let ar2 = actorAspect EM.! aid2 -- No problem if there are many projectiles at the spot. We just -- attack the first one. if | actorDying body2 @@ -596,7 +610,7 @@ let freq = uniformFreq "melee adjacent" $ catMaybes mels return $! liftFrequency freq --- | The level the actor is on is either explored or the actor already +-- The level the actor is on is either explored or the actor already -- has a weapon equipped, so no need to explore further, he tries to find -- enemies on other levels. -- We don't verify any embedded item is targeted by the actor, but at least @@ -613,7 +627,7 @@ pbags = mapMaybe f $ vicinityUnsafe (bpos b) efeat <- embedBenefit fleeVia aid pbags return $! liftFrequency $ toFreq "trigger" - [ (benefit, ReqAlter pos) + [ (ceiling benefit, ReqAlter pos) | (benefit, (pos, _)) <- efeat ] projectItem :: MonadClient m @@ -658,7 +672,7 @@ Nothing -> -10 -- experiment if no good options Just Benefit{benFling} -> benFling in if trange >= chessDist (bpos b) fpos && recharged - then Just ( - benR * rangeMult `div` 10 + then Just ( - ceiling (benR * fromIntegral rangeMult / 10) , ReqProject fpos newEps iid cstore ) else Nothing benRanged = mapMaybe fRanged benList @@ -677,9 +691,8 @@ condShineWouldBetray <- condShineWouldBetrayM aid condAimEnemyPresent <- condAimEnemyPresentM aid localTime <- getsState $ getLocalTime (blid b) - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) - calmE = calmEnough b ar + ar <- getsState $ getActorAspect aid + let calmE = calmEnough b ar condNotCalmEnough = not calmE heavilyDistressed = -- Actor hit by a projectile or similarly distressed. deltaSerious (bcalmDelta b) @@ -715,7 +728,7 @@ then Just $ toGroupName $ jname item else Nothing) organs itemLegal itemFull = - -- Don't include @Ascend@ not @Teleport@, because can be no foe nearby. + -- Don't include @Ascend@ nor @Teleport@, because can be no foe nearby. let getP (IK.RefillHP p) | p > 0 = True getP _ = False firstAidItem = case itemDisco itemFull of @@ -736,7 +749,7 @@ -- This assumes the organ dropping is beneficial and so worth -- saving for the future, for otherwise the item would not -- be considered at all, given that it's the only effect. - -- We don't try to intecept a case of many effects. + -- We don't try to intercept the case of many effects. let dropsGrps = strengthDropOrgan itemFull hasDropOrgan = not $ null dropsGrps f eff = [eff | IK.forApplyEffect eff] @@ -751,7 +764,7 @@ -- experimenting is fun, but it's better to risk -- foes' skin than ours Just Benefit{benApply} -> - benApply + ceiling benApply * if cstore == CEqp && not durable then 100000 -- must hinder currently else coeff cstore @@ -829,7 +842,7 @@ if boldpos b /= Just target -- avoid trivial loops && Tile.isWalkable coTileSpeedup (lvl `at` target) then do -- DisplaceAccess - mleader <- getsClient _sleader + mleader <- getsClient sleader mBlocker <- getsState $ posToAssocs target (blid b) case mBlocker of [] -> return reject @@ -870,6 +883,8 @@ mtgtMPath <- getsClient $ EM.lookup aid . stargetD lvl <- getLevel $ blid body let isAmbient pos = Tile.isLit coTileSpeedup (lvl `at` pos) + && Tile.isWalkable coTileSpeedup (lvl `at` pos) + -- if solid, will be altered and perhaps darkened str <- case mtgtMPath of Just TgtAndPath{tapPath=AndPath{pathList=q : _, ..}} | pathGoal == bpos body -> return reject -- shortcut and just to be sure @@ -918,7 +933,7 @@ freqs = map (liftFrequency . uniformFreq "moveTowards") groups return $! foldr (.|) reject freqs --- | Actor moves or searches or alters or attacks. +-- Actor moves or searches or alters or attacks. -- This function is very general, even though it's often used in contexts -- when only one or two of the many cases can possibly occur. moveOrRunAid :: MonadClient m diff --git a/Game/LambdaHack/Client/AI/PickActorM.hs b/Game/LambdaHack/Client/AI/PickActorM.hs --- a/Game/LambdaHack/Client/AI/PickActorM.hs +++ b/Game/LambdaHack/Client/AI/PickActorM.hs @@ -1,6 +1,6 @@ --- | Semantics of most 'ResponseAI' client commands. +-- | Picking the AI actor to move and refreshing leader and non-leader targets. module Game.LambdaHack.Client.AI.PickActorM - ( pickActorToMove, useTactics + ( pickActorToMove, setTargetFromTactics ) where import Prelude () @@ -8,7 +8,7 @@ import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM -import Data.Ratio +import Data.Ratio import Game.LambdaHack.Client.AI.ConditionM import Game.LambdaHack.Client.AI.PickTargetM @@ -29,13 +29,13 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ModeKind --- Pick a new leader from among the actors on the current level. +-- | Pick a new leader from among the actors on the current level. -- Refresh the target of the new leader, even if unchanged. pickActorToMove :: MonadClient m => Maybe ActorId -> m ActorId {-# INLINE pickActorToMove #-} pickActorToMove maidToAvoid = do - actorAspect <- getsClient sactorAspect - mleader <- getsClient _sleader + actorAspect <- getsState sactorAspect + mleader <- getsClient sleader let oldAid = fromMaybe (error $ "" `showFailure` maidToAvoid) mleader oldBody <- getsState $ getActorBody oldAid let side = bfid oldBody @@ -89,10 +89,10 @@ Just ((aid, b), tgt) _ -> Nothing oursTgtRaw <- mapM refresh ours + scondInMelee <- getsClient scondInMelee let oursTgt = mapMaybe goodGeneric oursTgtRaw -- This should be kept in sync with @actionStrategy@. actorVulnerable ((aid, body), _) = do - scondInMelee <- getsClient scondInMelee let condInMelee = fromMaybe (error $ "" `showFailure` condInMelee) (scondInMelee EM.! blid body) ar = fromMaybe (error $ "" `showFailure` aid) @@ -100,7 +100,7 @@ threatDistL <- meleeThreatDistList aid (fleeL, _) <- fleeList aid condSupport1 <- condSupport 1 aid - condSupport2 <- condSupport 2 aid + condSupport3 <- condSupport 3 aid canDeAmbientL <- getsState $ canDeAmbientList body let condCanFlee = not (null fleeL) speed1_5 = speedScale (3%2) (bspeed body ar) @@ -122,13 +122,14 @@ canFleeFromLight = not $ null $ aCanDeLightL `intersect` map snd fleeL return $! + -- This is a part of the condition for @flee@ in @HandleAbilityM@. not condFastThreatAdj && if | condThreat 1 -> not condCanMelee || condManyThreatAdj && not condSupport1 | not condInMelee && (condThreat 2 || condThreat 5 && canFleeFromLight) -> not condCanMelee - || not condSupport2 && not heavilyDistressed + || not condSupport3 && not heavilyDistressed -- not used: | condThreat 5 -> False -- because actor should be picked anyway, to try to melee | otherwise -> @@ -259,21 +260,29 @@ l : _ -> do let freq = toFreq "candidates for AI leader" $ map (positiveOverhead &&& id) l - ((aid, _), _) <- rndToAction $ frequency freq + ((aid, b), _) <- rndToAction $ frequency freq s <- getState modifyClient $ updateLeader aid s + -- When you become a leader, stop following old leader, but follow + -- his target, if still valid, to avoid distraction. + let condInMelee = fromMaybe (error $ "" `showFailure` condInMelee) + (scondInMelee EM.! blid b) + when (ftactic (gplayer fact) `elem` [TFollow, TFollowNoItems] + && not condInMelee) $ + void $ refreshTarget (aid, b) return aid _ -> return oldAid -useTactics :: MonadClient m => ActorId -> m () -{-# INLINE useTactics #-} -useTactics oldAid = do +-- | Inspect the tactics of the actor and set his target according to it. +setTargetFromTactics :: MonadClient m => ActorId -> m () +{-# INLINE setTargetFromTactics #-} +setTargetFromTactics oldAid = do + mleader <- getsClient sleader + let !_A = assert (mleader /= Just oldAid) () oldBody <- getsState $ getActorBody oldAid scondInMelee <- getsClient scondInMelee let condInMelee = fromMaybe (error $ "" `showFailure` condInMelee) (scondInMelee EM.! blid oldBody) - mleader <- getsClient _sleader - let !_A = assert (mleader /= Just oldAid) () let side = bfid oldBody arena = blid oldBody fact <- getsState $ (EM.! side) . sfactionD diff --git a/Game/LambdaHack/Client/AI/PickTargetM.hs b/Game/LambdaHack/Client/AI/PickTargetM.hs --- a/Game/LambdaHack/Client/AI/PickTargetM.hs +++ b/Game/LambdaHack/Client/AI/PickTargetM.hs @@ -15,33 +15,33 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Game.LambdaHack.Client.AI.ConditionM -import Game.LambdaHack.Client.AI.Strategy -import Game.LambdaHack.Client.Bfs -import Game.LambdaHack.Client.BfsM -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Common.Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Frequency -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Client.AI.ConditionM +import Game.LambdaHack.Client.AI.Strategy +import Game.LambdaHack.Client.Bfs +import Game.LambdaHack.Client.BfsM +import Game.LambdaHack.Client.CommonM +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State +import Game.LambdaHack.Common.Ability +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Frequency +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Content.TileKind (isUknownSpace) +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.RuleKind +import Game.LambdaHack.Content.TileKind (isUknownSpace) -- | Verify and possibly change the target of an actor. This function both -- updates the target in the client state and returns the new target explicitly. @@ -87,12 +87,12 @@ targetStrategy aid = do Kind.COps{corule, coTileSpeedup} <- getsState scops b <- getsState $ getActorBody aid - mleader <- getsClient _sleader + mleader <- getsClient sleader scondInMelee <- getsClient scondInMelee salter <- getsClient salter -- We assume the actor eventually becomes a leader (or has the same -- set of abilities as the leader, anyway) and set his target accordingly. - actorAspect <- getsClient sactorAspect + actorAspect <- getsState sactorAspect let lalter = salter EM.! blid b condInMelee = fromMaybe (error $ "" `showFailure` condInMelee) (scondInMelee EM.! blid b) @@ -145,7 +145,7 @@ -- Needed for now, because AI targets and shoots enemies -- based on the path to them, not LOS to them: || EM.findWithDefault 0 AbProject actorMaxSk > 0 - actorMinSk <- getsState $ actorSkills Nothing aid ar + actorMinSk <- getsState $ actorSkills Nothing aid condCanProject <- condCanProjectM (EM.findWithDefault 0 AbProject actorMaxSk) aid condEnoughGear <- condEnoughGearM aid @@ -316,6 +316,9 @@ pickNewTarget tileAdj :: (Point -> Bool) -> Point -> Bool tileAdj f p = any f $ vicinityUnsafe p + followingWrong permit = + permit && (condInMelee -- in melee, stop following + || mleader == Just aid) -- a leader, never follow updateTgt :: TgtAndPath -> m (Strategy TgtAndPath) updateTgt TgtAndPath{tapPath=NoPath} = pickNewTarget updateTgt tap@TgtAndPath{tapPath=AndPath{..},tapTgt} = case tapTgt of @@ -325,11 +328,9 @@ || not focused && not (null nearbyFoes)) -- prefers closer foes && a `notElem` map fst nearbyFoes -- old one not close enough || blid body /= blid b -- wrong level - || actorDying body -- foe already dying - || permit - && (condInMelee -- in melee, stop following - || mleader == Just aid) -> -- a leader, never follow + || actorDying body -> -- foe already dying pickNewTarget + | followingWrong permit -> pickNewTarget | bpos body == pathGoal -> return $! returN "TEnemy" tap -- The enemy didn't move since the target acquired. @@ -356,10 +357,7 @@ pickNewTarget -- prefer close foes to anything else TEnemyPos _ permit -- chase last position even if foe hides | bpos b == pos -> tellOthersNothingHere pos - | permit - && (condInMelee -- in melee, stop following - || mleader == Just aid) -> -- a leader, never follow - pickNewTarget -- melee, stop following + | followingWrong permit -> pickNewTarget | otherwise -> return $! returN "TEnemyPos" tap -- Below we check the target could not be picked again in -- pickNewTarget (e.g., an item got picked up by our teammate) @@ -395,13 +393,15 @@ -- to enable pickup; if pickup fails, will retarget | otherwise -> return $! returN "TItem" tap TSmell -> - if not canSmell - || let sml = EM.findWithDefault timeZero pos (lsmell lvl) - in sml <= ltime lvl - then pickNewTarget -- others will notice soon enough - else return $! returN "TSmell" tap + let lvl2 = sdungeon s EM.! lid + in if not canSmell + || let sml = EM.findWithDefault timeZero pos (lsmell lvl2) + in sml <= ltime lvl2 + then pickNewTarget -- others will notice soon enough + else return $! returN "TSmell" tap TUnknown -> - let t = lvl `at` pos + let lvl2 = sdungeon s EM.! lid + t = lvl2 `at` pos in if lidExplored || not (isUknownSpace t) || condEnoughGear && tileAdj (isStairPos lid) pos @@ -410,13 +410,19 @@ -- looks silly then pickNewTarget -- others will notice soon enough else return $! returN "TUnknown" tap - TKnown -> - if bpos b == pos - || isStuck - || alterSkill < fromEnum (lalter PointArray.! pos) - -- tile was searched or altered or skill lowered - then pickNewTarget -- others unconcerned - else return $! returN "TKnown" tap + TKnown -> -- e.g., staircase or first unknown tile of an area + let allExplored = ES.size explored == EM.size dungeon + lvl2 = sdungeon s EM.! lid + in if bpos b == pos + || isStuck + || alterSkill < fromEnum (lalter PointArray.! pos) + -- tile was searched or altered or skill lowered + || Tile.isWalkable coTileSpeedup (lvl2 `at` pos) + && not allExplored -- not patrolling explored dungeon + -- tile is no longer unwalkable, so was explored + -- so time to recalculate target + then pickNewTarget -- others unconcerned + else return $! returN "TKnown" tap TAny -> pickNewTarget -- reset elsewhere or carried over from UI TVector{} -> if pathLen > 1 then return $! returN "TVector" tap diff --git a/Game/LambdaHack/Client/AI/Strategy.hs b/Game/LambdaHack/Client/AI/Strategy.hs --- a/Game/LambdaHack/Client/AI/Strategy.hs +++ b/Game/LambdaHack/Client/AI/Strategy.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFoldable, DeriveTraversable, TupleSections #-} -- | AI strategies to direct actors not controlled directly by human players. --- No operation in this module involves the 'State' or 'Action' type. +-- No operation in this module involves the 'State' tyep or any of our +-- client/server monads types. module Game.LambdaHack.Client.AI.Strategy ( Strategy, nullStrategy, liftFrequency , (.|), reject, (.=>), only, bestVariant, renameStrategy, returN, mapStrategyM @@ -11,6 +12,7 @@ import Game.LambdaHack.Common.Prelude import Control.Applicative +import Data.Int (Int32) import Game.LambdaHack.Common.Frequency as Frequency @@ -19,12 +21,16 @@ newtype Strategy a = Strategy { runStrategy :: [Frequency a] } deriving (Show, Foldable, Traversable) --- | Strategy is a monad. +_maxBound32 :: Integer +_maxBound32 = toInteger (maxBound :: Int32) + instance Monad Strategy where - {-# INLINE return #-} - return x = Strategy $ return $! uniformFreq "Strategy_return" [x] m >>= f = normalizeStrategy $ Strategy - [ toFreq name [ (p * q, b) + [ toFreq name [ +#ifdef WITH_EXPENSIVE_ASSERTIONS + assert (toInteger p * toInteger q <= _maxBound32) +#endif + (p * q, b) | (p, a) <- runFrequency x , y <- runStrategy (f a) , (q, b) <- runFrequency y @@ -36,7 +42,8 @@ fmap f (Strategy fs) = Strategy (map (fmap f) fs) instance Applicative Strategy where - pure = return + {-# INLINE pure #-} + pure x = Strategy $ return $! uniformFreq "Strategy_pure" [x] (<*>) = ap instance MonadPlus Strategy where diff --git a/Game/LambdaHack/Client/Bfs.hs b/Game/LambdaHack/Client/Bfs.hs --- a/Game/LambdaHack/Client/Bfs.hs +++ b/Game/LambdaHack/Client/Bfs.hs @@ -1,11 +1,12 @@ {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} --- | Breadth first search algorithms. +-- | Breadth first search algorithm. module Game.LambdaHack.Client.Bfs ( BfsDistance, MoveLegal(..), minKnownBfs, apartBfs, fillBfs , AndPath(..), findPathBfs , accessBfs #ifdef EXPOSE_INTERNAL -- * Internal operations + , abortedKnownBfs, abortedUnknownBfs #endif ) where @@ -13,14 +14,14 @@ import Game.LambdaHack.Common.Prelude -import Control.Monad.ST.Strict -import Data.Binary -import Data.Bits (Bits, complement, (.&.), (.|.)) +import Control.Monad.ST.Strict +import Data.Binary +import Data.Bits (Bits, complement, (.&.), (.|.)) import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as VM -import GHC.Generics (Generic) +import GHC.Generics (Generic) -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -- | Weighted distance between points along shortest paths. diff --git a/Game/LambdaHack/Client/BfsM.hs b/Game/LambdaHack/Client/BfsM.hs --- a/Game/LambdaHack/Client/BfsM.hs +++ b/Game/LambdaHack/Client/BfsM.hs @@ -1,16 +1,14 @@ {-# LANGUAGE TupleSections #-} --- | Breadth first search and realted algorithms using the client monad. +-- | Breadth first search and related algorithms using the client monad. module Game.LambdaHack.Client.BfsM ( invalidateBfsAid, invalidateBfsLid, invalidateBfsAll - , createBfs, condBFS, getCacheBfsAndPath, getCacheBfs - , getCachePath, createPath - , unexploredDepth - , closestUnknown, closestSmell, furthestKnown - , FleeViaStairsOrEscape(..), embedBenefit, closestTriggers - , closestItems, closestFoes - , condEnoughGearM + , createBfs, getCacheBfsAndPath, getCacheBfs + , getCachePath, createPath, condBFS + , furthestKnown, closestUnknown, closestSmell + , FleeViaStairsOrEscape(..) + , embedBenefit, closestTriggers, condEnoughGearM, closestItems, closestFoes #ifdef EXPOSE_INTERNAL - , updatePathFromBfs + , unexploredDepth, updatePathFromBfs #endif ) where @@ -20,32 +18,32 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Ord -import Data.Word +import Data.Ord +import Data.Word -import Game.LambdaHack.Client.Bfs -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.Bfs +import Game.LambdaHack.Client.CommonM +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State import qualified Game.LambdaHack.Common.Ability as Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.TileKind (isUknownSpace) +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.TileKind (isUknownSpace) invalidateBfsAid :: MonadClient m => ActorId -> m () invalidateBfsAid aid = @@ -152,9 +150,9 @@ lvl <- getLevel $ blid b let stopAtUnwalkable tapPath@AndPath{..} = let (walkable, rest) = - -- Unknown tiles are not walkable, so path stops before them, - -- which is good, because by the time actor reaches them, - -- they are no longer unknown, so target invalidated. + -- Unknown tiles are not walkable, so path stops at first such. + -- which is good, because by the time actor reaches the tile, + -- it is known and target is recalculated with new info. span (Tile.isWalkable coTileSpeedup . at lvl) pathList in case rest of [] -> TgtAndPath{..} @@ -278,7 +276,7 @@ embedBenefit :: MonadClient m => FleeViaStairsOrEscape -> ActorId -> [(Point, ItemBag)] - -> m [(Int, (Point, ItemBag))] + -> m [(Double, (Point, ItemBag))] embedBenefit fleeVia aid pbags = do Kind.COps{coitem=Kind.Ops{okind}, coTileSpeedup} <- getsState scops dungeon <- getsState sdungeon @@ -293,7 +291,7 @@ unexploredTrue <- unexploredDepth True (blid b) unexploredFalse <- unexploredDepth False (blid b) condEnoughGear <- condEnoughGearM aid - discoKind <- getsClient sdiscoKind + discoKind <- getsState sdiscoKind discoBenefit <- getsClient sdiscoBenefit s <- getState let alterMinSkill p = Tile.alterMinSkill coTileSpeedup $ lvl `at` p @@ -340,7 +338,6 @@ _ -> 0 -- don't ascend prematurely _ -> if fleeVia `elem` [ViaNothing, ViaAnything] - then -- Actor uses the embedded item on himself, hence @effApply@. -- Let distance be the deciding factor and also prevent -- overflow on 32-bit machines. @@ -383,9 +380,8 @@ let mix (benefit, ppbag) dist = let maxd = fromEnum (maxBound :: BfsDistance) - fromEnum apartBfs - -- Bewqre of overflowing 32-bit integers here. - v = (maxd * 10) `div` (dist + 1) - in (benefit * v, ppbag) + v = (fromIntegral maxd * 10) / (fromIntegral dist + 1) + in (ceiling $ benefit * v, ppbag) in mapMaybe (\bpp@(_, (p, _)) -> mix bpp <$> accessBfs bfs p) vicAll diff --git a/Game/LambdaHack/Client/ClientOptions.hs b/Game/LambdaHack/Client/ClientOptions.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Client/ClientOptions.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | Options that affect the behaviour of the client. +module Game.LambdaHack.Client.ClientOptions + ( ClientOptions(..), defClientOptions + ) where + +import Prelude () + +import Game.LambdaHack.Common.Prelude + +import Data.Binary +import GHC.Generics (Generic) + +-- | Options that affect the behaviour of the client (but not game rules). +data ClientOptions = ClientOptions + { sgtkFontFamily :: Maybe Text + -- ^ Font family to use for the GTK main game window. + , sdlFontFile :: Maybe Text + -- ^ Font file to use for the SDL2 main game window. + , sdlTtfSizeAdd :: Maybe Int + -- ^ Pixels to add to map cells on top of scalable font max glyph height. + , sdlFonSizeAdd :: Maybe Int + -- ^ Pixels to add to map cells on top of .fon font max glyph height. + , sfontSize :: Maybe Int + -- ^ Font size to use for the main game window. + , scolorIsBold :: Maybe Bool + -- ^ Whether to use bold attribute for colorful characters. + , smaxFps :: Maybe Int + -- ^ Maximal frames per second. + -- This is better low and fixed, to avoid jerkiness and delays + -- that tell the player there are many intelligent enemies on the level. + -- That's better than scaling AI sofistication down based + -- on the FPS setting and machine speed. + , sdisableAutoYes :: Bool + -- ^ Never auto-answer all prompts, even if under AI control. + , snoAnim :: Maybe Bool + -- ^ Don't show any animations. + , snewGameCli :: Bool + -- ^ Start a new game, overwriting the save file. + , sbenchmark :: Bool + -- ^ Don't create directories and files and show time stats. + , stitle :: Maybe Text + , sfontDir :: Maybe FilePath + , ssavePrefixCli :: String + -- ^ Prefix of the save game file name. + , sfrontendTeletype :: Bool + -- ^ Whether to use the stdout/stdin frontend. + , sfrontendNull :: Bool + -- ^ Whether to use null (no input/output) frontend. + , sfrontendLazy :: Bool + -- ^ Whether to use lazy (output not even calculated) frontend. + , sdbgMsgCli :: Bool + -- ^ Show clients' internal debug messages. + , sstopAfterSeconds :: Maybe Int + , sstopAfterFrames :: Maybe Int + } + deriving (Show, Eq, Generic) + +instance Binary ClientOptions + +-- | Default value of client options. +defClientOptions :: ClientOptions +defClientOptions = ClientOptions + { sgtkFontFamily = Nothing + , sdlFontFile = Nothing + , sdlTtfSizeAdd = Nothing + , sdlFonSizeAdd = Nothing + , sfontSize = Nothing + , scolorIsBold = Nothing + , smaxFps = Nothing + , sdisableAutoYes = False + , snoAnim = Nothing + , snewGameCli = False + , sbenchmark = False + , stitle = Nothing + , sfontDir = Nothing + , ssavePrefixCli = "" + , sfrontendTeletype = False + , sfrontendNull = False + , sfrontendLazy = False + , sdbgMsgCli = False + , sstopAfterSeconds = Nothing + , sstopAfterFrames = Nothing + } diff --git a/Game/LambdaHack/Client/CommonM.hs b/Game/LambdaHack/Client/CommonM.hs --- a/Game/LambdaHack/Client/CommonM.hs +++ b/Game/LambdaHack/Client/CommonM.hs @@ -2,9 +2,8 @@ -- | Common client monad operations. module Game.LambdaHack.Client.CommonM ( getPerFid, aidTgtToPos, makeLine - , maxActorSkillsClient, currentSkillsClient, fullAssocsClient - , itemToFullClient, pickWeaponClient, updateSalter, createSalter - , aspectRecordFromItemClient, aspectRecordFromActorClient, createSactorAspect + , maxActorSkillsClient, currentSkillsClient, pickWeaponClient + , updateSalter, createSalter ) where import Prelude () @@ -13,26 +12,26 @@ import qualified Data.EnumMap.Strict as EM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.Request +import Game.LambdaHack.Client.State import qualified Game.LambdaHack.Common.Ability as Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace) +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace) -- | Get the current perception of a client. getPerFid :: MonadClient m => LevelId -> m Perception @@ -43,7 +42,8 @@ return $! EM.findWithDefault assFail lid fper -- | Calculate the position of an actor's target. -aidTgtToPos :: MonadClient m => ActorId -> LevelId -> Target -> m (Maybe Point) +aidTgtToPos :: MonadStateRead m + => ActorId -> LevelId -> Target -> m (Maybe Point) aidTgtToPos aid lidV tgt = case tgt of TEnemy a _ -> do @@ -65,7 +65,7 @@ -- an actor or obstacle. Starts searching with the given eps and returns -- the first found eps for which the number reaches the distance between -- actor and target position, or Nothing if none can be found. -makeLine :: MonadClient m => Bool -> Actor -> Point -> Int -> m (Maybe Int) +makeLine :: MonadStateRead m => Bool -> Actor -> Point -> Int -> m (Maybe Int) makeLine onlyFirst body fpos epsOld = do Kind.COps{coTileSpeedup} <- getsState scops lvl@Level{lxsize, lysize} <- getLevel (blid body) @@ -73,7 +73,7 @@ let dist = chessDist (bpos body) fpos calcScore eps = case bla lxsize lysize eps (bpos body) fpos of Just bl -> - let blDist = take dist bl + let blDist = take (dist - 1) bl -- goal not checked; actor well aware noActor p = all (bproj . snd) (posA p) || p == fpos accessibleUnknown tpos = let tt = lvl `at` tpos @@ -101,44 +101,23 @@ | otherwise -> tryLines (epsOld + 1) (Nothing, minBound) -- generate best +-- @MonadStateRead@ would be enough, but the logic is sound only on client. maxActorSkillsClient :: MonadClient m => ActorId -> m Ability.Skills maxActorSkillsClient aid = do - actorAspect <- getsClient sactorAspect - case EM.lookup aid actorAspect of - Just aspectRecord -> return $ aSkills aspectRecord -- keep it lazy - Nothing -> error $ "" `showFailure` aid + ar <- getsState $ getActorAspect aid + return $ aSkills ar -- keep it lazy currentSkillsClient :: MonadClient m => ActorId -> m Ability.Skills currentSkillsClient aid = do - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) body <- getsState $ getActorBody aid side <- getsClient sside - -- Newest Leader in _sleader, not yet in sfactionD. + -- Newest Leader in sleader, not yet in sfactionD. mleader <- if side == bfid body - then getsClient _sleader + then getsClient sleader else do fact <- getsState $ (EM.! bfid body) . sfactionD - return $! _gleader fact - getsState $ actorSkills mleader aid ar -- keep it lazy - -fullAssocsClient :: MonadClient m - => ActorId -> [CStore] -> m [(ItemId, ItemFull)] -fullAssocsClient aid cstores = do - cops <- getsState scops - discoKind <- getsClient sdiscoKind - discoAspect <- getsClient sdiscoAspect - getsState $ fullAssocs cops discoKind discoAspect aid cstores - -itemToFullClient :: MonadClient m => m (ItemId -> ItemQuant -> ItemFull) -itemToFullClient = do - cops <- getsState scops - discoKind <- getsClient sdiscoKind - discoAspect <- getsClient sdiscoAspect - s <- getState - let itemToF iid = itemToFull cops discoKind discoAspect iid - (getItemBody iid s) - return itemToF + return $! gleader fact + getsState $ actorSkills mleader aid -- keep it lazy -- Client has to choose the weapon based on its partial knowledge, -- because if server chose it, it would leak item discovery information. @@ -146,15 +125,13 @@ => ActorId -> ActorId -> m (Maybe (RequestTimed 'Ability.AbMelee)) pickWeaponClient source target = do - eqpAssocs <- fullAssocsClient source [CEqp] - bodyAssocs <- fullAssocsClient source [COrgan] + eqpAssocs <- getsState $ fullAssocs source [CEqp] + bodyAssocs <- getsState $ fullAssocs source [COrgan] actorSk <- currentSkillsClient source - actorAspect <- getsClient sactorAspect let allAssocsRaw = eqpAssocs ++ bodyAssocs allAssocs = filter (isMelee . itemBase . snd) allAssocsRaw discoBenefit <- getsClient sdiscoBenefit - strongest <- pickWeaponM (Just discoBenefit) - allAssocs actorSk actorAspect source + strongest <- pickWeaponM (Just discoBenefit) allAssocs actorSk source case strongest of [] -> return Nothing iis@((maxS, _) : _) -> do @@ -177,45 +154,3 @@ f Level{ltile} = PointArray.mapA (toEnum . Tile.alterMinWalk coTileSpeedup) ltile in EM.map f $ sdungeon s - -aspectRecordFromItem :: DiscoveryKind -> DiscoveryAspect -> ItemId -> Item - -> AspectRecord -aspectRecordFromItem disco discoAspect iid itemBase = - case EM.lookup iid discoAspect of - Just ar -> ar - Nothing -> case EM.lookup (jkindIx itemBase) disco of - Just KindMean{kmMean} -> kmMean - Nothing -> emptyAspectRecord - -aspectRecordFromItemClient :: MonadClient m => ItemId -> Item -> m AspectRecord -aspectRecordFromItemClient iid itemBase = do - disco <- getsClient sdiscoKind - discoAspect <- getsClient sdiscoAspect - return $! aspectRecordFromItem disco discoAspect iid itemBase - -aspectRecordFromActorState :: DiscoveryKind -> DiscoveryAspect -> Actor -> State - -> AspectRecord -aspectRecordFromActorState disco discoAspect b s = - let processIid (iid, (k, _)) = - let itemBase = getItemBody iid s - ar = aspectRecordFromItem disco discoAspect iid itemBase - in (ar, k) - processBag ass = sumAspectRecord $ map processIid ass - in processBag $ EM.assocs (borgan b) ++ EM.assocs (beqp b) - -aspectRecordFromActorClient :: MonadClient m - => Actor -> [(ItemId, Item)] -> m AspectRecord -aspectRecordFromActorClient b ais = do - disco <- getsClient sdiscoKind - discoAspect <- getsClient sdiscoAspect - s <- getState - let f (iid, itemBase) = EM.insert iid itemBase - sAis = updateItemD (\itemD -> foldr f itemD ais) s - return $! aspectRecordFromActorState disco discoAspect b sAis - -createSactorAspect :: MonadClient m => State -> m ActorAspect -createSactorAspect s = do - disco <- getsClient sdiscoKind - discoAspect <- getsClient sdiscoAspect - let f b = aspectRecordFromActorState disco discoAspect b s - return $! EM.map f $ sactorD s diff --git a/Game/LambdaHack/Client/HandleAtomicM.hs b/Game/LambdaHack/Client/HandleAtomicM.hs --- a/Game/LambdaHack/Client/HandleAtomicM.hs +++ b/Game/LambdaHack/Client/HandleAtomicM.hs @@ -1,6 +1,14 @@ -- | Handle atomic commands received by the client. module Game.LambdaHack.Client.HandleAtomicM - ( cmdAtomicSemCli, cmdAtomicFilterCli + ( MonadClientSetup(..) + , cmdAtomicSemCli +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , wipeBfsIfItemAffectsSkills, tileChangeAffectsBfs, createActor, destroyActor + , addItemToDiscoBenefit, perception + , discoverKind, coverKind, discoverSeed, coverSeed + , killExit +#endif ) where import Prelude () @@ -8,268 +16,75 @@ import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM -import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M -import Data.Ord -import qualified NLP.Miniutter.English as MU +import Data.Ord -import Game.LambdaHack.Atomic -import Game.LambdaHack.Client.Bfs -import Game.LambdaHack.Client.BfsM -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.Preferences -import Game.LambdaHack.Client.State -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Atomic +import Game.LambdaHack.Client.Bfs +import Game.LambdaHack.Client.BfsM +import Game.LambdaHack.Client.CommonM +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.Preferences +import Game.LambdaHack.Client.State +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind (ModeKind) -import Game.LambdaHack.Content.TileKind (TileKind) -import qualified Game.LambdaHack.Content.TileKind as TK - --- * RespUpdAtomicAI +import Game.LambdaHack.Content.ModeKind (ModeKind) +import Game.LambdaHack.Content.TileKind (TileKind) --- | Clients keep a subset of atomic commands sent by the server --- and add some of their own. The result of this function is the list --- of commands kept for each command received. -cmdAtomicFilterCli :: MonadClient m => UpdAtomic -> m [UpdAtomic] -{-# INLINE cmdAtomicFilterCli #-} -cmdAtomicFilterCli cmd = case cmd of - UpdSpotActor aid _ _ -> do - -- Needed, e.g., when we teleport and so see our actor at the new - -- location, but also the location is part of new perception, - -- so @UpdSpotActor@ is sent. - alreadyAdded <- getsState $ EM.member aid . sactorD - return $! if alreadyAdded then [] else [cmd] - UpdAlterTile lid p fromTile toTile -> do - Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops - lvl <- getLevel lid - let t = lvl `at` p - if t == fromTile - then return [cmd] - else do - -- From @UpdAlterTile@ we know @t == freshClientTile@, - -- which is uncanny, so we produce a message. - -- It happens when a client thinks the tile is @t@, - -- but it's @fromTile@, and @UpdAlterTile@ changes it - -- to @toTile@. See @updAlterTile@. - let subject = "" -- a hack, we we don't handle adverbs well - verb = "turn into" - msg = makeSentence [ "the", MU.Text $ TK.tname $ okind t - , "at position", MU.Text $ tshow p - , "suddenly" -- adverb - , MU.SubjectVerbSg subject verb - , MU.AW $ MU.Text $ TK.tname $ okind toTile ] - return [ cmd -- reveal the tile - , UpdMsgAll msg -- show the message - ] - UpdSearchTile aid p toTile -> do - Kind.COps{cotile} <- getsState scops - b <- getsState $ getActorBody aid - lvl <- getLevel $ blid b - let t = lvl `at` p - fromTile = Tile.hideAs cotile toTile - return $! - if t == fromTile - then -- Fully ignorant. (No intermediate knowledge possible.) - [ cmd -- show the message - , UpdAlterTile (blid b) p fromTile toTile -- reveal tile - ] - else assert (t == toTile `blame` "LoseTile fails to reset memory" - `swith` (aid, p, fromTile, toTile, b, t, cmd)) - [cmd] -- Already knows the tile fully, only confirm. - UpdHideTile{} -> return [] -- will be fleshed out when Undo completed - UpdSpotTile lid ts -> do - Kind.COps{cotile} <- getsState scops - lvl <- getLevel lid - -- We ignore the server resending us hidden versions of the tiles - -- (and resending us the same data we already got). - -- If the tiles are changed to other variants of the hidden tile, - -- we can still verify by searching. - let notKnown (p, t) = let tClient = lvl `at` p - in Tile.hideAs cotile tClient /= t - newTs = filter notKnown ts - return $! if null newTs then [] else [UpdSpotTile lid newTs] - UpdDiscover c iid _ seed -> do - itemD <- getsState sitemD - case EM.lookup iid itemD of - Nothing -> return [] - Just item -> do - discoKind <- getsClient sdiscoKind - if jkindIx item `EM.member` discoKind - then do - discoAspect <- getsClient sdiscoAspect - if iid `EM.member` discoAspect - then return [] - else return [UpdDiscoverSeed c iid seed] - else return [cmd] - UpdCover c iid ik _ -> do - itemD <- getsState sitemD - case EM.lookup iid itemD of - Nothing -> return [] - Just item -> do - discoKind <- getsClient sdiscoKind - if jkindIx item `EM.notMember` discoKind - then return [] - else do - discoAspect <- getsClient sdiscoAspect - if iid `EM.notMember` discoAspect - then return [cmd] - else return [UpdCoverKind c iid ik] - UpdDiscoverKind _ iid _ -> do - itemD <- getsState sitemD - case EM.lookup iid itemD of - Nothing -> return [] - Just item -> do - discoKind <- getsClient sdiscoKind - if jkindIx item `EM.notMember` discoKind - then return [] - else return [cmd] - UpdCoverKind _ iid _ -> do - itemD <- getsState sitemD - case EM.lookup iid itemD of - Nothing -> return [] - Just item -> do - discoKind <- getsClient sdiscoKind - if jkindIx item `EM.notMember` discoKind - then return [] - else return [cmd] - UpdDiscoverSeed _ iid _ -> do - itemD <- getsState sitemD - case EM.lookup iid itemD of - Nothing -> return [] - Just item -> do - discoKind <- getsClient sdiscoKind - if jkindIx item `EM.notMember` discoKind - then return [] - else do - discoAspect <- getsClient sdiscoAspect - if iid `EM.member` discoAspect - then return [] - else return [cmd] - UpdCoverSeed _ iid _ -> do - itemD <- getsState sitemD - case EM.lookup iid itemD of - Nothing -> return [] - Just item -> do - discoKind <- getsClient sdiscoKind - if jkindIx item `EM.notMember` discoKind - then return [] - else do - discoAspect <- getsClient sdiscoAspect - if iid `EM.notMember` discoAspect - then return [] - else return [cmd] - UpdPerception lid outPer inPer -> do - -- Here we cheat by setting a new perception outright instead of - -- in @cmdAtomicSemCli@, to avoid computing perception twice. - perOld <- getPerFid lid - perception lid outPer inPer - perNew <- getPerFid lid - carriedAssocs <- getsState $ flip getCarriedAssocs - fid <- getsClient sside - s <- getState - -- Wipe out actors that just became invisible due to changed FOV. - let seenNew = seenAtomicCli False fid perNew - seenOld = seenAtomicCli False fid perOld - outFov = totalVisible outPer - outPrio = concatMap (\p -> posToAssocs p lid s) $ ES.elems outFov - fActor (aid, b) = - let ps = posProjBody b - -- Verify that we forget only previously seen actors. - !_A = assert (seenOld ps) () - in -- We forget only currently invisible actors. - if seenNew ps - then Nothing - else Just $ UpdLoseActor aid b $ carriedAssocs b - outActor = mapMaybe fActor outPrio - -- Wipe out remembered items on tiles that now came into view. - lvl <- getLevel lid - let inFov = ES.elems $ totalVisible inPer - pMaybe p = maybe Nothing (\x -> Just (p, x)) - inContainer fc itemFloor = - let inItem = mapMaybe (\p -> pMaybe p $ EM.lookup p itemFloor) inFov - fItem p (iid, kit) = - UpdLoseItem True iid (getItemBody iid s) kit (fc lid p) - fBag (p, bag) = map (fItem p) $ EM.assocs bag - in concatMap fBag inItem - inFloor = inContainer CFloor (lfloor lvl) - inEmbed = inContainer CEmbed (lembed lvl) - -- Remembered map tiles not wiped out, due to optimization in @updSpotTile@. - -- Wipe out remembered smell on tiles that now came into smell Fov. - let inSmellFov = totalSmelled inPer - inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl)) - (ES.elems inSmellFov) - inSmell = if null inSm then [] else [UpdLoseSmell lid inSm] - let inTileSmell = inFloor ++ inEmbed ++ inSmell - psItemSmell <- mapM posUpdAtomic inTileSmell - -- Verify that we forget only previously invisible items and smell. - let !_A = assert (allB (not . seenOld) psItemSmell) () - -- Verify that we forget only currently seen items and smell. - let !_A = assert (allB seenNew psItemSmell) () - return $! cmd : outActor ++ inTileSmell - _ -> return [cmd] +-- | Client monad for saving and restarting games. +class MonadClient m => MonadClientSetup m where + saveClient :: m () + restartClient :: m () --- | Effect of atomic actions on client state is calculated --- with the global state from before the command is executed. -cmdAtomicSemCli :: MonadClientSetup m => UpdAtomic -> m () +-- | Effect of atomic actions on client state. It is calculated +-- with the global state from after the command is executed +-- (except where the supplied @oldState@ is used). +cmdAtomicSemCli :: MonadClientSetup m => State -> UpdAtomic -> m () {-# INLINE cmdAtomicSemCli #-} -cmdAtomicSemCli cmd = case cmd of +cmdAtomicSemCli oldState cmd = case cmd of UpdCreateActor aid b ais -> createActor aid b ais UpdDestroyActor aid b _ -> destroyActor aid b True - UpdCreateItem iid itemBase (k, _) (CActor aid store) -> do + UpdCreateItem iid itemBase _ (CActor aid store) -> do wipeBfsIfItemAffectsSkills [store] aid - when (store `elem` [CEqp, COrgan]) $ addItemToActor iid itemBase k aid addItemToDiscoBenefit iid itemBase UpdCreateItem iid itemBase _ _ -> addItemToDiscoBenefit iid itemBase - UpdDestroyItem iid itemBase (k, _) (CActor aid store) -> do + UpdDestroyItem _ _ _ (CActor aid store) -> wipeBfsIfItemAffectsSkills [store] aid - when (store `elem` [CEqp, COrgan]) $ addItemToActor iid itemBase (-k) aid UpdSpotActor aid b ais -> createActor aid b ais UpdLoseActor aid b _ -> destroyActor aid b False - UpdSpotItem _ iid itemBase (k, _) (CActor aid store) -> do + UpdSpotItem _ iid itemBase _ (CActor aid store) -> do wipeBfsIfItemAffectsSkills [store] aid - when (store `elem` [CEqp, COrgan]) $ addItemToActor iid itemBase k aid addItemToDiscoBenefit iid itemBase UpdSpotItem _ iid itemBase _ _ -> addItemToDiscoBenefit iid itemBase - UpdLoseItem _ iid itemBase (k, _) (CActor aid store) -> do + UpdLoseItem _ _ _ _ (CActor aid store) -> wipeBfsIfItemAffectsSkills [store] aid - when (store `elem` [CEqp, COrgan]) $ addItemToActor iid itemBase (-k) aid + UpdSpotItemBag (CActor aid store) _bag ais -> do + wipeBfsIfItemAffectsSkills [store] aid + mapM_ (\(iid, item) -> addItemToDiscoBenefit iid item) ais + UpdSpotItemBag _ _ ais -> + mapM_ (\(iid, item) -> addItemToDiscoBenefit iid item) ais + UpdLoseItemBag (CActor aid store) _bag _ais -> + wipeBfsIfItemAffectsSkills [store] aid UpdMoveActor aid _ _ -> invalidateBfsAid aid UpdDisplaceActor source target -> do invalidateBfsAid source invalidateBfsAid target - UpdMoveItem iid k aid s1 s2 -> do - wipeBfsIfItemAffectsSkills [s1, s2] aid - case s1 of - CEqp -> case s2 of - COrgan -> return () - _ -> do - itemBase <- getsState $ getItemBody iid - addItemToActor iid itemBase (-k) aid - COrgan -> case s2 of - CEqp -> return () - _ -> do - itemBase <- getsState $ getItemBody iid - addItemToActor iid itemBase (-k) aid - _ -> - when (s2 `elem` [CEqp, COrgan]) $ do - itemBase <- getsState $ getItemBody iid - addItemToActor iid itemBase k aid + UpdMoveItem _ _ aid s1 s2 -> wipeBfsIfItemAffectsSkills [s1, s2] aid UpdLeadFaction fid source target -> do side <- getsClient sside when (side == fid) $ do - mleader <- getsClient _sleader + mleader <- getsClient sleader let !_A = assert (mleader == source -- somebody changed the leader for us || mleader == target @@ -282,7 +97,7 @@ invalidateBfsAll UpdTacticFaction{} -> do -- Clear all targets except the leader's. - mleader <- getsClient _sleader + mleader <- getsClient sleader mtgt <- case mleader of Nothing -> return Nothing Just leader -> getsClient $ EM.lookup leader . stargetD @@ -290,19 +105,35 @@ cli { stargetD = case (mtgt, mleader) of (Just tgt, Just leader) -> EM.singleton leader tgt _ -> EM.empty } - UpdAlterTile lid pos _fromTile toTile -> do - updateSalter lid [(pos, toTile)] + UpdAlterTile lid p fromTile toTile -> do + updateSalter lid [(p, toTile)] cops <- getsState scops - lvl <- getLevel lid - let assumedTile = lvl `at` pos - when (tileChangeAffectsBfs cops assumedTile toTile) $ + let lvl = (EM.! lid) . sdungeon $ oldState + t = lvl `at` p + let !_A = assert (t == fromTile) () + when (tileChangeAffectsBfs cops fromTile toTile) $ invalidateBfsLid lid + UpdSearchTile aid p toTile -> do + Kind.COps{cotile} <- getsState scops + b <- getsState $ getActorBody aid + let lid = blid b + updateSalter lid [(p, toTile)] + cops <- getsState scops + let lvl = (EM.! lid) . sdungeon $ oldState + t = lvl `at` p + let !_A = assert (Just t == Tile.hideAs cotile toTile) () + -- The following check is needed even if we verity in content + -- that searching doesn't change clarity and light of tiles, + -- because it modifies skill needed to alter the tile and even + -- walkability and changeability. + when (tileChangeAffectsBfs cops t toTile) $ + invalidateBfsLid lid UpdSpotTile lid ts -> do updateSalter lid ts cops <- getsState scops - lvl <- getLevel lid - let affects (pos, toTile) = - let fromTile = lvl `at` pos + let lvl = (EM.! lid) . sdungeon $ oldState + affects (p, toTile) = + let fromTile = lvl `at` p in tileChangeAffectsBfs cops fromTile toTile bs = map affects ts when (or bs) $ invalidateBfsLid lid @@ -315,17 +146,19 @@ let g !em !lid = EM.adjust (const Nothing) lid em in cli {scondInMelee = foldl' g (scondInMelee cli) arenas} UpdDiscover c iid ik seed -> do - discoverKind c iid ik + item <- getsState $ getItemBody iid + discoverKind c (jkindIx item) ik discoverSeed c iid seed UpdCover c iid ik seed -> do coverSeed c iid seed - coverKind c iid ik - UpdDiscoverKind c iid ik -> discoverKind c iid ik - UpdCoverKind c iid ik -> coverKind c iid ik + item <- getsState $ getItemBody iid + coverKind c (jkindIx item) ik + UpdDiscoverKind c ix ik -> discoverKind c ix ik + UpdCoverKind c ix ik -> coverKind c ix ik UpdDiscoverSeed c iid seed -> discoverSeed c iid seed UpdCoverSeed c iid seed -> coverSeed c iid seed - -- UpdPerception lid outPer inPer -> perception lid outPer inPer - UpdRestart side sdiscoKind sfper s scurChal sdebugCli -> do + UpdPerception lid outPer inPer -> perception lid outPer inPer + UpdRestart side sfper s scurChal soptions -> do Kind.COps{comode=Kind.Ops{ofoldlGroup'}} <- getsState scops snxtChal <- getsClient snxtChal svictories <- getsClient svictories @@ -337,19 +170,16 @@ Just cm -> fromMaybe 0 (M.lookup snxtChal cm) (snxtScenario, _) = minimumBy (comparing g) modes cli = emptyStateClient side - putClient cli { sdiscoKind - , sfper + putClient cli { sfper -- , sundo = [UpdAtomic cmd] , scurChal , snxtChal , snxtScenario , scondInMelee = EM.map (const Nothing) (sdungeon s) , svictories - , sdebugCli } - modifyClient $ \cli1 -> cli1 {salter = createSalter s} - -- Currently always void, because no actors yet: - sactorAspect <- createSactorAspect s - modifyClient $ \cli1 -> cli1 {sactorAspect} + , soptions } + salter <- getsState createSalter + modifyClient $ \cli1 -> cli1 {salter} restartClient UpdResume _fid sfperNew -> do #ifdef WITH_EXPENSIVE_ASSERTIONS @@ -357,10 +187,8 @@ let !_A = assert (sfperNew == sfperOld `blame` (sfperNew, sfperOld)) () #endif modifyClient $ \cli -> cli {sfper=sfperNew} - s <- getState - modifyClient $ \cli -> cli {salter = createSalter s} - sactorAspect <- createSactorAspect s - modifyClient $ \cli -> cli {sactorAspect} + salter <- getsState createSalter + modifyClient $ \cli -> cli {salter} UpdKillExit _fid -> killExit UpdWriteSave -> saveClient _ -> return () @@ -386,9 +214,6 @@ TgtAndPath (TEnemy a newPermit) NoPath _ -> tap modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)} - aspectRecord <- aspectRecordFromActorClient b ais - let f = EM.insert aid aspectRecord - modifyClient $ \cli -> cli {sactorAspect = f $ sactorAspect cli} mapM_ (uncurry addItemToDiscoBenefit) ais destroyActor :: MonadClient m => ActorId -> Actor -> Bool -> m () @@ -411,30 +236,23 @@ _ -> tapPath -- foe slow enough, so old path good in TgtAndPath (affect tapTgt) newMPath modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)} - let f = EM.delete aid - modifyClient $ \cli -> cli {sactorAspect = f $ sactorAspect cli} -addItemToActor :: MonadClient m => ItemId -> Item -> Int -> ActorId -> m () -addItemToActor iid itemBase k aid = do - arItem <- aspectRecordFromItemClient iid itemBase - let g arActor = sumAspectRecord [(arActor, 1), (arItem, k)] - f = EM.adjust g aid - modifyClient $ \cli -> cli {sactorAspect = f $ sactorAspect cli} - addItemToDiscoBenefit :: MonadClient m => ItemId -> Item -> m () addItemToDiscoBenefit iid item = do cops@Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops discoBenefit <- getsClient sdiscoBenefit case EM.lookup iid discoBenefit of - Just{} -> return () -- already there + Just{} -> return () -- already there, possibly with real aspects, too Nothing -> do - discoKind <- getsClient sdiscoKind + discoKind <- getsState sdiscoKind case EM.lookup (jkindIx item) discoKind of Nothing -> return () Just KindMean{..} -> do -- possible, if the kind sent in @UpdRestart@ side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD let effects = IK.ieffects $ okind kmKind + -- Mean aspects are used, because the item can't yet have + -- know real aspects, because it didn't even have kind before. benefit = totalUsefulness cops fact effects kmMean item modifyClient $ \cli -> cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)} @@ -464,90 +282,52 @@ f = EM.alter adj lid modifyClient $ \cli -> cli {sfper = f (sfper cli)} -discoverKind :: MonadClient m => Container -> ItemId -> Kind.Id ItemKind -> m () -discoverKind c iid kmKind = do +discoverKind :: MonadClient m + => Container -> ItemKindIx -> Kind.Id ItemKind -> m () +discoverKind _c ix ik = do cops@Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops -- Wipe out BFS, because the player could potentially learn that his items -- affect his actors' skills relevant to BFS. invalidateBfsAll side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD - item <- getsState $ getItemBody iid - let kind = okind kmKind - kmMean = meanAspect kind - benefit = totalUsefulness cops fact (IK.ieffects kind) kmMean item - f Nothing = Just KindMean{..} - f Just{} = error $ "already discovered" - `showFailure` (c, iid, kmKind) - -- This adds to @sdiscoBenefit@ only @iid@ and not any other items - -- that share the same @jkindIx@, so this is broken if such items - -- are not fully IDed from the start. - modifyClient $ \cli -> - cli { sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli) - , sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli) } - -- Each actor's equipment and organs would need to be inspected, - -- the iid looked up, e.g., if it wasn't in old discoKind, but is in new, - -- and then aspect record updated, so it's simpler and not much more - -- expensive to generate new sactorAspect. Optimize only after profiling. - s <- getState - sactorAspect <- createSactorAspect s - modifyClient $ \cli -> cli {sactorAspect} + discoKind <- getsState sdiscoKind + itemD <- getsState sitemD + let effs = IK.ieffects $ okind ik + KindMean{kmMean} = fromMaybe (error "item kind not found") + (EM.lookup ix discoKind) + benefit iid = + let item = itemD EM.! iid + in totalUsefulness cops fact effs kmMean item + itemIxMap <- getsState $ (EM.! ix) . sitemIxMap + forM_ itemIxMap $ \iid -> modifyClient $ \cli -> + cli {sdiscoBenefit = EM.insert iid (benefit iid) (sdiscoBenefit cli)} -coverKind :: MonadClient m => Container -> ItemId -> Kind.Id ItemKind -> m () -coverKind c iid ik = do - item <- getsState $ getItemBody iid - let f Nothing = error $ "already covered" `showFailure` (c, iid, ik) - f (Just KindMean{kmKind}) = - assert (ik == kmKind `blame` "unexpected covered item kind" - `swith` (ik, kmKind)) Nothing - -- For now, undoing @sdiscoBenefit@ is too much work. - modifyClient $ \cli -> - cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)} - s <- getState - sactorAspect <- createSactorAspect s - modifyClient $ \cli -> cli {sactorAspect} +coverKind :: Container -> ItemKindIx -> Kind.Id ItemKind -> m () +coverKind _c _iid _ik = undefined discoverSeed :: MonadClient m => Container -> ItemId -> ItemSeed -> m () -discoverSeed c iid seed = do +discoverSeed _c iid seed = do cops@Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops -- Wipe out BFS, because the player could potentially learn that his items -- affect his actors' skills relevant to BFS. invalidateBfsAll side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD - discoKind <- getsClient sdiscoKind + discoKind <- getsState sdiscoKind item <- getsState $ getItemBody iid totalDepth <- getsState stotalDepth - case EM.lookup (jkindIx item) discoKind of - Nothing -> error $ "kind not known" - `showFailure` (c, iid, seed) - Just KindMean{kmKind} -> do - Level{ldepth} <- getLevel $ jlid item - let kind = okind kmKind - aspects = seedToAspect seed kind ldepth totalDepth - benefit = totalUsefulness cops fact (IK.ieffects kind) aspects item - f Nothing = Just aspects - f Just{} = error $ "already discovered" - `showFailure` (c, iid, seed) - -- This adds to @sdiscoBenefit@ only @iid@ and not any other items - -- that share the same @jkindIx@, so this is broken if such items - -- are not fully IDed from the start. - modifyClient $ \cli -> - cli { sdiscoAspect = EM.alter f iid (sdiscoAspect cli) - , sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli) } - s <- getState - sactorAspect <- createSactorAspect s - modifyClient $ \cli -> cli {sactorAspect} + Level{ldepth} <- getLevel $ jlid item + let KindMean{..} = fromMaybe (error "item kind not found") + (EM.lookup (jkindIx item) discoKind) + kind = okind kmKind + aspects = seedToAspect seed kind ldepth totalDepth + benefit = totalUsefulness cops fact (IK.ieffects kind) aspects item + modifyClient $ \cli -> + cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)} -coverSeed :: MonadClient m => Container -> ItemId -> ItemSeed -> m () -coverSeed c iid seed = do - let f Nothing = error $ "already covered" `showFailure` (c, iid, seed) - f Just{} = Nothing -- checking that old and new agree is too much work - -- For now, undoing @sdiscoBenefit@ is too much work. - modifyClient $ \cli -> cli {sdiscoAspect = EM.alter f iid (sdiscoAspect cli)} - s <- getState - sactorAspect <- createSactorAspect s - modifyClient $ \cli -> cli {sactorAspect} +coverSeed :: Container -> ItemId -> ItemSeed -> m () +coverSeed _c _iid _seed = undefined killExit :: MonadClient m => m () killExit = do @@ -556,12 +336,11 @@ modifyClient $ \cli -> cli {squit = True} -- Verify that the not saved caches are equal to future reconstructed. -- Otherwise, save/restore would change game state. - sactorAspect <- getsClient sactorAspect + sactorAspect2 <- getsState sactorAspect salter <- getsClient salter sbfsD <- getsClient sbfsD - s <- getState - let alter = createSalter s - actorAspect <- createSactorAspect s + alter <- getsState createSalter + actorAspect <- getsState actorAspectInDungeon let f aid = do (canMove, alterSkill) <- condBFS aid bfsArr <- createBfs canMove alterSkill aid @@ -579,9 +358,9 @@ let !_A1 = assert (salter == alter `blame` "wrong accumulated salter on side" `swith` (side, salter, alter)) () - !_A2 = assert (sactorAspect == actorAspect + !_A2 = assert (sactorAspect2 == actorAspect `blame` "wrong accumulated sactorAspect on side" - `swith` (side, sactorAspect, actorAspect)) () + `swith` (side, sactorAspect2, actorAspect)) () !_A3 = assert (sbfsD `subBfs` bfsD `blame` "wrong accumulated sbfsD on side" `swith` (side, sbfsD, bfsD)) () diff --git a/Game/LambdaHack/Client/HandleResponseM.hs b/Game/LambdaHack/Client/HandleResponseM.hs --- a/Game/LambdaHack/Client/HandleResponseM.hs +++ b/Game/LambdaHack/Client/HandleResponseM.hs @@ -1,7 +1,8 @@ {-# LANGUAGE FlexibleContexts #-} --- | Semantics of client commands. +-- | Semantics of responses sent by the server to clients. module Game.LambdaHack.Client.HandleResponseM - ( MonadClientReadResponse(..), MonadClientWriteRequest(..) + ( MonadClientWriteRequest(..) + , MonadClientAtomic(..) , handleResponse ) where @@ -9,37 +10,55 @@ import Game.LambdaHack.Common.Prelude -import Game.LambdaHack.Atomic +import Game.LambdaHack.Atomic (UpdAtomic) import Game.LambdaHack.Client.AI import Game.LambdaHack.Client.HandleAtomicM import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.Request +import Game.LambdaHack.Client.Response import Game.LambdaHack.Client.UI -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.Response - -class MonadClient m => MonadClientReadResponse m where - receiveResponse :: m Response +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.State +-- | Client monad in which one can send requests to the client. class MonadClient m => MonadClientWriteRequest m where sendRequestAI :: RequestAI -> m () sendRequestUI :: RequestUI -> m () clientHasUI :: m Bool +-- | Monad for executing atomic game state transformations on a client. +class MonadClient m => MonadClientAtomic m where + -- | Execute an atomic update that changes the client's 'State'. + execUpdAtomic :: UpdAtomic -> m () + -- | Put state that is intended to be the result of performing + -- an atomic update by the server on its copy of the client's 'State'. + execPutState :: State -> m () + +-- | Handle server responses. +-- +-- Note that for clients communicating with the server over the net, +-- @RespUpdAtomicNoState@ should be used, because executing a single command +-- is cheaper than sending the whole state over the net. +-- However, for the standalone exe mode, with clients in the same process +-- as the server, a pointer to the state set with @execPutState@ is cheaper. handleResponse :: ( MonadClientSetup m , MonadClientUI m - , MonadAtomic m + , MonadClientAtomic m , MonadClientWriteRequest m ) => Response -> m () handleResponse cmd = case cmd of - RespUpdAtomic cmdA -> do + RespUpdAtomic newState cmdA -> do + oldState <- getState + execPutState newState + cmdAtomicSemCli oldState cmdA hasUI <- clientHasUI - cmds <- cmdAtomicFilterCli cmdA - let handle !c = do - cli <- getClient - cmdAtomicSemCli c - execUpdAtomic c - when hasUI $ displayRespUpdAtomicUI False cli c - mapM_ handle cmds + when hasUI $ displayRespUpdAtomicUI False cmdA + RespUpdAtomicNoState cmdA -> do + oldState <- getState + execUpdAtomic cmdA + cmdAtomicSemCli oldState cmdA + hasUI <- clientHasUI + when hasUI $ displayRespUpdAtomicUI False cmdA RespQueryAI aid -> do cmdC <- queryAI aid sendRequestAI cmdC diff --git a/Game/LambdaHack/Client/LoopM.hs b/Game/LambdaHack/Client/LoopM.hs --- a/Game/LambdaHack/Client/LoopM.hs +++ b/Game/LambdaHack/Client/LoopM.hs @@ -2,7 +2,12 @@ -- | The main loop of the client, processing human and computer player -- moves turn by turn. module Game.LambdaHack.Client.LoopM - ( loopCli + ( MonadClientReadResponse(..) + , loopCli +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , initAI, initUI +#endif ) where import Prelude () @@ -10,63 +15,74 @@ import Game.LambdaHack.Common.Prelude import Game.LambdaHack.Atomic +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client.HandleAtomicM import Game.LambdaHack.Client.HandleResponseM import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.Response import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI -import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Response import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Vector -initAI :: MonadClient m => DebugModeCli -> m () -initAI sdebugCli = do - modifyClient $ \cli -> cli {sdebugCli} +-- | Client monad in which one can receive responses from the server. +class MonadClient m => MonadClientReadResponse m where + receiveResponse :: m Response + +initAI :: MonadClient m => m () +initAI = do side <- getsClient sside debugPossiblyPrint $ "AI client" <+> tshow side <+> "initializing." -initUI :: MonadClientUI m => KeyKind -> Config -> DebugModeCli -> m () -initUI copsClient sconfig sdebugCli = do - modifyClient $ \cli -> cli {sdebugCli} +initUI :: MonadClientUI m => KeyKind -> UIOptions -> m () +initUI copsClient sUIOptions = do side <- getsClient sside + soptions <- getsClient soptions debugPossiblyPrint $ "UI client" <+> tshow side <+> "initializing." -- Start the frontend. - schanF <- chanFrontend sdebugCli - let !sbinding = stdBinding copsClient sconfig -- evaluate to check for errors - sess = emptySessionUI sconfig - putSession sess { schanF - , sbinding - , sxhair = TVector $ Vector 1 1 } - -- a step south-east, less alarming + schanF <- chanFrontend soptions + let !sbinding = stdBinding copsClient sUIOptions + -- evaluate to check for errors + modifySession $ \sess -> + sess { schanF + , sbinding + , sxhair = TVector $ Vector 1 1 } + -- a step south-east, less alarming --- | The main game loop for an AI or UI client. +-- | The main game loop for an AI or UI client. It receives responses from +-- the server, changes internal client state accordingly, analyzes +-- ensuing human or AI commands and sends resulting requests to the server. +-- Depending on whether it's an AI or UI client, it sends AI or human player +-- requests. +-- +-- The loop is started in client state that is empty except for +-- the @sside@ and @seps@ fields, see 'emptyStateClient'. loopCli :: ( MonadClientSetup m , MonadClientUI m - , MonadAtomic m + , MonadClientAtomic m , MonadClientReadResponse m , MonadClientWriteRequest m ) - => KeyKind -> Config -> DebugModeCli -> m () -loopCli copsClient sconfig sdebugCli = do + => KeyKind -> UIOptions -> ClientOptions -> m () +loopCli copsClient sUIOptions soptions = do + modifyClient $ \cli -> cli {soptions} hasUI <- clientHasUI - if not hasUI then initAI sdebugCli else initUI copsClient sconfig sdebugCli + if not hasUI then initAI else initUI copsClient sUIOptions -- Warning: state and client state are invalid here, e.g., sdungeon -- and sper are empty. cops <- getsState scops restoredG <- tryRestore restored <- case restoredG of - Just (s, cli, msess) | not $ snewGameCli sdebugCli -> do + Just (cli, msess) | not $ snewGameCli soptions -> do -- Restore game. - let sCops = updateCOps (const cops) s - handleResponse $ RespUpdAtomic $ UpdResumeServer sCops schanF <- getsSession schanF sbinding <- getsSession sbinding - maybe (return ()) (\sess -> - putSession sess {schanF, sbinding, sconfig}) msess - putClient cli {sdebugCli} + maybe (return ()) (\sess -> modifySession $ \_ -> + sess {schanF, sbinding, sUIOptions}) msess + putClient cli {soptions} return True - Just (_, _, msessR) -> do + Just (_, msessR) -> do -- Preserve previous history, if any (--newGame). maybe (return ()) (\sessR -> modifySession $ \sess -> sess {shistory = shistory sessR}) msessR @@ -75,13 +91,22 @@ side <- getsClient sside cmd1 <- receiveResponse case (restored, cmd1) of - (True, RespUpdAtomic UpdResume{}) -> return () - (True, RespUpdAtomic UpdRestart{}) -> + (True, RespUpdAtomic s UpdResume{}) -> do + let sCops = updateCOps (const cops) s + handleResponse $ RespUpdAtomic sCops $ UpdResumeServer sCops + (True, RespUpdAtomic _ UpdRestart{}) -> when hasUI $ msgAdd "Ignoring an old savefile and starting a new game." - (False, RespUpdAtomic UpdResume{}) -> + (False, RespUpdAtomic _ UpdResume{}) -> error $ "Savefile of client " ++ show side ++ " not usable." `showFailure` () - (False, RespUpdAtomic UpdRestart{}) -> return () + (False, RespUpdAtomic _ UpdRestart{}) -> return () + (True, RespUpdAtomicNoState UpdResume{}) -> undefined + (True, RespUpdAtomicNoState UpdRestart{}) -> + when hasUI $ msgAdd "Ignoring an old savefile and starting a new game." + (False, RespUpdAtomicNoState UpdResume{}) -> + error $ "Savefile of client " ++ show side ++ " not usable." + `showFailure` () + (False, RespUpdAtomicNoState UpdRestart{}) -> return () _ -> error $ "unexpected command" `showFailure` (side, restored, cmd1) handleResponse cmd1 -- State and client state now valid. diff --git a/Game/LambdaHack/Client/MonadClient.hs b/Game/LambdaHack/Client/MonadClient.hs --- a/Game/LambdaHack/Client/MonadClient.hs +++ b/Game/LambdaHack/Client/MonadClient.hs @@ -1,12 +1,10 @@ -- | Basic client monad and related operations. module Game.LambdaHack.Client.MonadClient - ( -- * Basic client monad - MonadClient( getsClient, modifyClient + ( -- * Basic client monads + MonadClient( getsClient + , modifyClient , liftIO -- exposed only to be implemented, not used ) - , MonadClientSetup( saveClient - , restartClient - ) -- * Assorted primitives , getClient, putClient , debugPossiblyPrint, rndToAction, rndToActionForget @@ -18,14 +16,15 @@ import qualified Control.Monad.Trans.State.Strict as St import qualified Data.Text.IO as T -import System.IO (hFlush, stdout) +import System.IO (hFlush, stdout) import qualified System.Random as R +import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.State -import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Random +-- | Monad for writing to client state. class MonadStateRead m => MonadClient m where getsClient :: (StateClient -> a) -> m a modifyClient :: (StateClient -> StateClient) -> m () @@ -33,10 +32,6 @@ -- nobody can subvert the action monads by invoking arbitrary IO. liftIO :: IO a -> m a -class MonadClient m => MonadClientSetup m where - saveClient :: m () - restartClient :: m () - getClient :: MonadClient m => m StateClient getClient = getsClient id @@ -45,7 +40,7 @@ debugPossiblyPrint :: MonadClient m => Text -> m () debugPossiblyPrint t = do - sdbgMsgCli <- getsClient $ sdbgMsgCli . sdebugCli + sdbgMsgCli <- getsClient $ sdbgMsgCli . soptions when sdbgMsgCli $ liftIO $ do T.hPutStrLn stdout t hFlush stdout @@ -55,7 +50,7 @@ rndToAction r = do gen <- getsClient srandom let (gen1, gen2) = R.split gen - modifyClient $ \ser -> ser {srandom = gen1} + modifyClient $ \cli -> cli {srandom = gen1} return $! St.evalState r gen2 -- | Invoke pseudo-random computation, don't change generator kept in state. diff --git a/Game/LambdaHack/Client/Preferences.hs b/Game/LambdaHack/Client/Preferences.hs --- a/Game/LambdaHack/Client/Preferences.hs +++ b/Game/LambdaHack/Client/Preferences.hs @@ -1,9 +1,11 @@ --- | Actor preferences for targets and actions based on actor attributes. +-- | Actor preferences for targets and actions, based on actor attributes. module Game.LambdaHack.Client.Preferences ( totalUsefulness #ifdef EXPOSE_INTERNAL -- * Internal operations - , effectToBenefit, organBenefit, aspectToBenefit, recordToBenefit + , effectToBenefit + , averageTurnValue, avgItemDelay, avgItemLife, durabilityMult + , organBenefit, recBenefit, fakeItem, aspectToBenefit, recordToBenefit #endif ) where @@ -12,17 +14,17 @@ import Game.LambdaHack.Common.Prelude import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Flavour -import Game.LambdaHack.Common.Frequency -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemStrongest +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Flavour +import Game.LambdaHack.Common.Frequency +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.ModeKind -- | How much AI benefits from applying the effect. -- The first component is benefit when applied to self, the second @@ -36,7 +38,7 @@ -- So there is less than @averageTurnValue@ included in each benefit, -- so in case when turn is not spent, e.g, periodic or temporary effects, -- the difference in value is only slight. -effectToBenefit :: Kind.COps -> Faction -> IK.Effect -> (Int, Int) +effectToBenefit :: Kind.COps -> Faction -> IK.Effect -> (Double, Double) effectToBenefit cops fact eff = let delta x = (x, x) in case eff of @@ -47,12 +49,16 @@ IK.Explode _ -> delta 1 -- depends on explosion, but usually good, -- unless under OnSmash, but they are ignored IK.RefillHP p -> - delta $ if p > 0 then min 2000 (20 * p) else max (-1000) (10 * p) + delta $ if p > 0 + then min 2000 (20 * fromIntegral p) + else max (-1000) (10 * fromIntegral p) -- one HP healed is worth a bit more than one HP dealed to enemy, -- because if the actor survives, he may deal damage many times; -- however, AI is mostly for non-heroes that fight in suicidal crowds, -- so the two values are kept close enough to maintain berserk approach - IK.RefillCalm p -> delta $ if p > 0 then min 9 p else max (-9) p + IK.RefillCalm p -> delta $ if p > 0 + then min 9 (fromIntegral p) + else max (-9) (fromIntegral p) IK.Dominate -> (0, -300) -- I obtained an actor with, say 10HP, -- worth 200, and enemy lost him, another 100 IK.Impress -> (5, -50) -- usually has no effect on self, hence low value @@ -75,7 +81,7 @@ IK.Paralyze d -> delta $ -20 * Dice.meanDice d -- clips IK.InsertMove d -> delta $ 100 * Dice.meanDice d -- turns IK.Teleport d -> if Dice.meanDice d <= 8 - then (1, 0) -- blink to shoot at foes + then (1, 0) -- blink to shoot at foes else (-9, -1) -- for self, don't derail exploration -- for foes, fight with one less at a time IK.CreateItem COrgan "temporary condition" _ -> @@ -86,8 +92,9 @@ IK.TimerGameTurn n -> Dice.meanDice n IK.TimerActorTurn n -> Dice.meanDice n (total, count) = organBenefit turnTimer grp cops fact - in delta $ total `divUp` count -- the same when created in me and in foe - -- average over all matching grps; simplified: rarities ignored + in delta $ total / fromIntegral count + -- the same when created in me and in foe + -- average over all matching grps; simplified: rarities ignored IK.CreateItem _ "treasure" _ -> (100, 0) -- assumed not temporary IK.CreateItem _ "useful" _ -> (70, 0) IK.CreateItem _ "any scroll" _ -> (50, 0) @@ -96,7 +103,7 @@ IK.CreateItem _ "flask" _ -> (50, 0) IK.CreateItem _ grp _ -> -- assumed not temporary and @grp@ tiny let (total, count) = recBenefit grp cops fact - in (total `divUp` count, 0) + in (total / fromIntegral count, 0) IK.DropItem _ _ COrgan "temporary condition" -> (1, -1) -- varied, big bunch, but try to nullify it anyway IK.DropItem ngroup kcopy COrgan grp -> -- assumed temporary @@ -110,15 +117,16 @@ (total, count) = organBenefit turnTimer grp cops fact boundBonus n = if n == maxBound then 10 else 0 in delta $ boundBonus ngroup + boundBonus kcopy - - total `divUp` count -- the same when dropped from me and foe + - total / fromIntegral count + -- the same when dropped from me and foe IK.DropItem{} -> delta (-10) -- depends a lot on what is dropped IK.PolyItem -> delta 0 -- AI can't estimate item desirability vs average IK.Identify -> delta 0 -- AI doesn't know how to use - IK.Detect radius -> (radius * 2, 0) - IK.DetectActor radius -> (radius, 0) - IK.DetectItem radius -> (radius, 0) - IK.DetectExit radius -> (radius, 0) - IK.DetectHidden radius -> (radius, 0) + IK.Detect radius -> (fromIntegral radius * 2, 0) + IK.DetectActor radius -> (fromIntegral radius, 0) + IK.DetectItem radius -> (fromIntegral radius, 0) + IK.DetectExit radius -> (fromIntegral radius, 0) + IK.DetectHidden radius -> (fromIntegral radius, 0) IK.SendFlying _ -> (1, -10) -- very context dependent, but it's better IK.PushActor _ -> (1, -10) -- to be the one that decides and not the one IK.PullActor _ -> (1, -10) -- that is interrupted in the middle of fleeing @@ -130,16 +138,22 @@ let bs = map (effectToBenefit cops fact) efs f (self, foe) (accSelf, accFoe) = (self + accSelf, foe + accFoe) (effSelf, effFoe) = foldr f (0, 0) bs - in (effSelf `divUp` length bs, effFoe `divUp` length bs) + in (effSelf / fromIntegral (length bs), effFoe / fromIntegral (length bs)) IK.OnSmash _ -> delta 0 -- can be beneficial; we'd need to analyze explosions, range, etc. IK.Recharging _ -> delta 0 -- taken into account separately IK.Temporary _ -> delta 0 -- assumed for created organs only IK.Unique -> delta 0 IK.Periodic -> delta 0 -- considered in totalUsefulness + IK.Composite [] -> delta 0 + IK.Composite (eff1 : _) -> effectToBenefit cops fact eff1 + -- for simplicity; so in content make sure to place initial animations + -- among normal effects, not at the start of composite effect + -- (animations should not fail, after all), and start composite + -- effect with the main thing -- See the comment for @Paralyze@. -averageTurnValue :: Int +averageTurnValue :: Double averageTurnValue = 10 -- Average delay between desired item uses. Some items are best activated @@ -156,7 +170,7 @@ -- We don't want to undervalue rarely used items with long timeouts -- and we think that most interesting gameplay comes from alternating -- item use, so we arbitrarily set the full value timeout to 3. -avgItemDelay :: Int +avgItemDelay :: Double avgItemDelay = 3 -- The average time between item being found (and enough skill obtained @@ -173,14 +187,14 @@ -- We set the value to 30, assuming if the actor finds an item, then he is -- most likely at an unlooted level, so he will find more loot soon, -- or he is in a battle, so he will die soon (or win even more loot). -avgItemLife :: Int +avgItemLife :: Double avgItemLife = 30 -- The value of durable item is this many times higher than non-durable, -- because the item will on average be activated this many times -- before it stops being used. -durabilityMult :: Int -durabilityMult = avgItemLife `div` avgItemDelay +durabilityMult :: Double +durabilityMult = avgItemLife / avgItemDelay -- We assume the organ is temporary (@Temporary@, @Periodic@, @Timeout 0@) -- and also that it doesn't provide any functionality, e.g., detection @@ -212,19 +226,20 @@ -- are applied and we can't stop/restart them. -- -- We assume, only one of timer and count mechanisms is present at once. -organBenefit :: Int -> GroupName ItemKind -> Kind.COps -> Faction -> (Int, Int) +organBenefit :: Double -> GroupName ItemKind -> Kind.COps -> Faction + -> (Double, Int) organBenefit turnTimer grp cops@Kind.COps{coitem=Kind.Ops{ofoldlGroup'}} fact = let f (!sacc, !pacc) !p _ !kind = - let paspect asp = p * aspectToBenefit asp - peffect eff = p * fst (effectToBenefit cops fact eff) + let paspect asp = fromIntegral p * aspectToBenefit asp + peffect eff = fromIntegral p * fst (effectToBenefit cops fact eff) in ( sacc + Dice.meanDice (IK.icount kind) * (sum (map paspect $ IK.iaspects kind) + sum (map peffect $ stripRecharging $ IK.ieffects kind)) - - averageTurnValue `div` turnTimer + - averageTurnValue / turnTimer , pacc + p ) in ofoldlGroup' grp f (0, 0) -recBenefit :: GroupName ItemKind -> Kind.COps -> Faction -> (Int, Int) +recBenefit :: GroupName ItemKind -> Kind.COps -> Faction -> (Double, Int) recBenefit grp cops@Kind.COps{coitem=Kind.Ops{ofoldlGroup'}} fact = let f (!sacc, !pacc) !p _ !kind = let recPickup = benPickup $ @@ -267,15 +282,15 @@ -- Valuation of effects, and more precisely, more the signs than absolute -- values, ensures that both shield and torch get picked up so that -- the (human) actor can nevertheless equip them in very special cases. -aspectToBenefit :: IK.Aspect -> Int +aspectToBenefit :: IK.Aspect -> Double aspectToBenefit asp = case asp of IK.Timeout{} -> 0 IK.AddHurtMelee p -> Dice.meanDice p -- offence favoured - IK.AddArmorMelee p -> Dice.meanDice p `divUp` 4 -- only partial protection - IK.AddArmorRanged p -> Dice.meanDice p `divUp` 8 + IK.AddArmorMelee p -> Dice.meanDice p / 4 -- only partial protection + IK.AddArmorRanged p -> Dice.meanDice p / 8 IK.AddMaxHP p -> Dice.meanDice p - IK.AddMaxCalm p -> Dice.meanDice p `divUp` 5 + IK.AddMaxCalm p -> Dice.meanDice p / 5 IK.AddSpeed p -> Dice.meanDice p * 25 -- 1 speed ~ 5% melee; times 5 for no caps, escape, pillar-dancing, etc.; -- also, it's 1 extra turn each 20 turns, so 100/20, so 5; figures @@ -286,10 +301,13 @@ IK.AddAggression{} -> 0 IK.AddAbility _ p -> Dice.meanDice p * 5 -recordToBenefit :: AspectRecord -> [Int] +recordToBenefit :: AspectRecord -> [Double] recordToBenefit aspects = map aspectToBenefit $ aspectRecordToList aspects --- Result has non-strict fields, so arguments are forced to avoid leaks. +-- | Compute the whole 'Benefit' structure, containing various facets +-- of AI item preference, for an item with the given effects and aspects. +-- +-- Note: result has non-strict fields, so arguments are forced to avoid leaks. -- When AI looks at items (including organs) more often, force the fields. totalUsefulness :: Kind.COps -> Faction -> [IK.Effect] -> AspectRecord -> Item -> Benefit @@ -309,8 +327,9 @@ let scaleChargeBens bens | timeout <= 3 = bens | otherwise = map (\eff -> - if avgItemDelay >= timeout then eff - else eff * avgItemDelay `divUp` timeout) bens + if avgItemDelay >= fromIntegral timeout + then eff + else eff * avgItemDelay / fromIntegral timeout) bens (cself, cfoe) = unzip $ map (effectToBenefit cops fact) (stripRecharging effects) in (scaleChargeBens cself, scaleChargeBens cfoe) @@ -348,12 +367,12 @@ benApply = max 0 $ -- because optional; I don't need to apply (effSelf + effDice -- hits self with dice too, when applying + if periodic then 0 else sum chargeSelf) - `divUp` if durable then 1 else durabilityMult + / if durable then 1 else durabilityMult -- For melee, we add the foe part. benMelee = min 0 $ (effFoe + effDice -- @AddHurtMelee@ already in @eqpSum@ + if periodic then 0 else sum chargeFoe) - `divUp` if durable then 1 else durabilityMult + / if durable then 1 else durabilityMult -- The periodic effects, if any, are activated when projectile flies, -- but not when it hits, so they are not added to @benFling@. -- However, if item is not periodic, the recharging effects @@ -361,17 +380,17 @@ benFling = min 0 $ effFoe + benFlingDice -- nothing in @eqpSum@; normally not worn + if periodic then 0 else sum chargeFoe - benFlingDice | jdamage item <= 0 = 0 -- speedup + benFlingDice | jdamage item == 0 = 0 -- speedup | otherwise = assert (v <= 0) v where hurtMult = 100 + min 99 (max (-99) (aHurtMelee aspects)) -- assumes no enemy armor and no block dmg = Dice.meanDice (jdamage item) - rawDeltaHP = fromIntegral hurtMult * xM dmg `divUp` 100 + rawDeltaHP = ceiling $ fromIntegral hurtMult * xD dmg / 100 -- For simplicity, we ignore range bonus/malus and @Lobable@. IK.ThrowMod{IK.throwVelocity} = strengthToThrow item speed = speedFromWeight (jweight item) throwVelocity - v = fromEnum $ - modifyDamageBySpeed rawDeltaHP speed * 10 `div` oneM + v = - fromIntegral (modifyDamageBySpeed rawDeltaHP speed) * 10 / xD 1 -- 1 damage valued at 10, just as in @damageUsefulness@ -- For equipment benefit, we take into account only the self -- value of the recharging effects, because they applied to self. diff --git a/Game/LambdaHack/Client/Request.hs b/Game/LambdaHack/Client/Request.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Client/Request.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DataKinds, GADTs, KindSignatures, StandaloneDeriving #-} +-- | Abstract syntax of requests. +-- +-- See +-- . +module Game.LambdaHack.Client.Request + ( RequestAI, ReqAI(..), RequestUI, ReqUI(..) + , RequestAnyAbility(..), RequestTimed(..) + ) where + +import Prelude () + +import Game.LambdaHack.Common.Prelude + +import Game.LambdaHack.Common.Ability +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.ModeKind + +-- | Requests sent by AI clients to the server. If faction leader is to be +-- changed, it's included as the second component. +type RequestAI = (ReqAI, Maybe ActorId) + +-- | Possible forms of requests sent by AI clients. +data ReqAI = + ReqAINop + | ReqAITimed RequestAnyAbility + deriving Show + +-- | Requests sent by UI clients to the server. If faction leader is to be +-- changed, it's included as the second component. +type RequestUI = (ReqUI, Maybe ActorId) + +-- | Possible forms of requests sent by UI clients. +data ReqUI = + ReqUINop + | ReqUITimed RequestAnyAbility + | ReqUIGameRestart (GroupName ModeKind) Challenge + | ReqUIGameExit + | ReqUIGameSave + | ReqUITactic Tactic + | ReqUIAutomate + deriving Show + +-- | Basic form of requests, sent by both AI and UI clients to the server. +data RequestAnyAbility = forall a. RequestAnyAbility (RequestTimed a) + +deriving instance Show RequestAnyAbility + +-- | Requests that take game time, indexed by actor ability +-- that is needed for performing the corresponding actions. +data RequestTimed :: Ability -> * where + ReqMove :: Vector -> RequestTimed 'AbMove + ReqMelee :: ActorId -> ItemId -> CStore -> RequestTimed 'AbMelee + ReqDisplace :: ActorId -> RequestTimed 'AbDisplace + ReqAlter :: Point -> RequestTimed 'AbAlter + ReqWait :: RequestTimed 'AbWait + ReqWait10 :: RequestTimed 'AbWait + ReqMoveItems :: [(ItemId, Int, CStore, CStore)] -> RequestTimed 'AbMoveItem + ReqProject :: Point -> Int -> ItemId -> CStore -> RequestTimed 'AbProject + ReqApply :: ItemId -> CStore -> RequestTimed 'AbApply + +deriving instance Show (RequestTimed a) diff --git a/Game/LambdaHack/Client/Response.hs b/Game/LambdaHack/Client/Response.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Client/Response.hs @@ -0,0 +1,33 @@ +-- | Abstract syntax of responses. +-- +-- See +-- . +module Game.LambdaHack.Client.Response + ( Response(..) + ) where + +import Prelude () + +import Game.LambdaHack.Common.Prelude + +import Game.LambdaHack.Atomic +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.State + +-- | Abstract syntax of responses sent by server to an AI or UI client +-- (or a universal client that can handle both roles, which is why +-- this type is not separated into distinct AI and UI types). +-- A response tells a client how to update game state or what information +-- to send to the server. +data Response = + RespUpdAtomicNoState UpdAtomic + -- ^ change @State@ by performing this atomic update + | RespUpdAtomic State UpdAtomic + -- ^ put the given @State@, which results from performing the atomic update + | RespQueryAI ActorId + -- ^ compute an AI move for the actor and send (the semantics of) it + | RespSfxAtomic SfxAtomic + -- ^ perform special effects (animations, messages, etc.) + | RespQueryUI + -- ^ prompt the human player for a command and send (the semantics of) it + deriving Show diff --git a/Game/LambdaHack/Client/State.hs b/Game/LambdaHack/Client/State.hs --- a/Game/LambdaHack/Client/State.hs +++ b/Game/LambdaHack/Client/State.hs @@ -1,82 +1,72 @@ {-# LANGUAGE DeriveGeneric #-} --- | Server and client game state types and operations. +-- | Client-specific game state components. module Game.LambdaHack.Client.State - ( StateClient(..), emptyStateClient - , AlterLid - , updateTarget, getTarget, updateLeader, sside - , BfsAndPath(..), TgtAndPath(..), cycleMarkSuspect + ( StateClient(..), AlterLid, BfsAndPath(..), TgtAndPath(..) + , emptyStateClient, cycleMarkSuspect + , updateTarget, getTarget, updateLeader, sside, sleader ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M -import GHC.Generics (Generic) +import GHC.Generics (Generic) import qualified System.Random as R -import Game.LambdaHack.Atomic -import Game.LambdaHack.Client.Bfs -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.ClientOptions -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Atomic +import Game.LambdaHack.Client.Bfs +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.State -import Game.LambdaHack.Content.ModeKind (ModeKind) +import Game.LambdaHack.Common.State +import Game.LambdaHack.Content.ModeKind (ModeKind) -- | Client state, belonging to a single faction. --- Some of the data, e.g, the history, carries over --- from game to game, even across playing sessions. --- --- When many actors want to fling at the same target, they set --- their personal targets to follow the common xhair. --- When each wants to kill a fleeing enemy they recently meleed, --- they keep the enemies as their personal targets. --- --- Data invariant: if @_sleader@ is @Nothing@ then so is @srunning@. data StateClient = StateClient - { seps :: Int -- ^ a parameter of the aiming digital line + { seps :: Int -- ^ a parameter of the aiming digital line , stargetD :: EM.EnumMap ActorId TgtAndPath - -- ^ targets of our actors in the dungeon + -- ^ targets of our actors in the dungeon , sexplored :: ES.EnumSet LevelId - -- ^ the set of fully explored levels + -- ^ the set of fully explored levels , sbfsD :: EM.EnumMap ActorId BfsAndPath - -- ^ pathfinding distances for our actors - -- and paths to their targets, if any - , sundo :: [CmdAtomic] -- ^ atomic commands performed to date - , sdiscoKind :: DiscoveryKind -- ^ remembered item discoveries - , sdiscoAspect :: DiscoveryAspect -- ^ remembered aspects of items - , sdiscoBenefit :: DiscoveryBenefit -- ^ remembered AI benefits of items - , sactorAspect :: ActorAspect -- ^ best known actor aspect data - , sfper :: PerLid -- ^ faction perception indexed by levels - , salter :: AlterLid -- ^ cached alter ability data for positions - , srandom :: R.StdGen -- ^ current random generator - , _sleader :: Maybe ActorId - -- ^ candidate new leader of the faction; - -- Faction._gleader is the old leader - , _sside :: FactionId -- ^ faction controlled by the client - , squit :: Bool -- ^ exit the game loop - , scurChal :: Challenge -- ^ current game challenge setup - , snxtChal :: Challenge -- ^ next game challenge setup - , snxtScenario :: Int -- ^ next game scenario number - , smarkSuspect :: Int -- ^ mark suspect features + -- ^ pathfinding data for our actors + , sundo :: [CmdAtomic] -- ^ atomic commands performed to date + , sdiscoBenefit :: DiscoveryBenefit + -- ^ remembered AI benefits of items + , sfper :: PerLid -- ^ faction perception indexed by level + , salter :: AlterLid -- ^ cached alter ability data for positions + , srandom :: R.StdGen -- ^ current random generator + , _sleader :: Maybe ActorId -- ^ candidate new leader of the faction; + -- Faction.gleader is the old leader + , _sside :: FactionId -- ^ faction controlled by the client + , squit :: Bool -- ^ exit the game loop + , scurChal :: Challenge -- ^ current game challenge setup + , snxtChal :: Challenge -- ^ next game challenge setup + , snxtScenario :: Int -- ^ next game scenario number + , smarkSuspect :: Int -- ^ whether to mark suspect features , scondInMelee :: EM.EnumMap LevelId (Maybe Bool) - -- ^ condInMelee value, unless invalidated + -- ^ last in-melee condition for each level , svictories :: EM.EnumMap (Kind.Id ModeKind) (M.Map Challenge Int) - -- ^ won games at particular difficulty levels - , sdebugCli :: DebugModeCli -- ^ client debugging mode + -- ^ won games at particular difficulty lvls + , soptions :: ClientOptions -- ^ client options } deriving Show +type AlterLid = EM.EnumMap LevelId (PointArray.Array Word8) + +-- | Pathfinding distances to all reachable positions of an actor +-- and a shortest paths to some of the positions. data BfsAndPath = BfsInvalid | BfsAndPath { bfsArr :: PointArray.Array BfsDistance @@ -84,13 +74,12 @@ } deriving Show +-- | Actor's target and a path to it, if any. data TgtAndPath = TgtAndPath {tapTgt :: Target, tapPath :: AndPath} deriving (Show, Generic) instance Binary TgtAndPath -type AlterLid = EM.EnumMap LevelId (PointArray.Array Word8) - -- | Initial empty game client state. emptyStateClient :: FactionId -> StateClient emptyStateClient _sside = @@ -100,10 +89,7 @@ , sexplored = ES.empty , sbfsD = EM.empty , sundo = [] - , sdiscoKind = EM.empty - , sdiscoAspect = EM.empty , sdiscoBenefit = EM.empty - , sactorAspect = EM.empty , sfper = EM.empty , salter = EM.empty , srandom = R.mkStdGen 42 -- will get modified in this and future games @@ -116,9 +102,10 @@ , smarkSuspect = 1 , scondInMelee = EM.empty , svictories = EM.empty - , sdebugCli = defDebugModeCli + , soptions = defClientOptions } +-- | Cycle the 'smarkSuspect' setting. cycleMarkSuspect :: StateClient -> StateClient cycleMarkSuspect s@StateClient{smarkSuspect} = s {smarkSuspect = (smarkSuspect + 1) `mod` 3} @@ -148,14 +135,15 @@ sside :: StateClient -> FactionId sside = _sside +sleader :: StateClient -> Maybe ActorId +sleader = _sleader + instance Binary StateClient where put StateClient{..} = do put seps put stargetD put sexplored put sundo - put sdiscoKind - put sdiscoAspect put sdiscoBenefit put (show srandom) put _sleader @@ -166,7 +154,7 @@ put smarkSuspect put scondInMelee put svictories - put sdebugCli + put soptions #ifdef WITH_EXPENSIVE_ASSERTIONS put sfper #endif @@ -175,8 +163,6 @@ stargetD <- get sexplored <- get sundo <- get - sdiscoKind <- get - sdiscoAspect <- get sdiscoBenefit <- get g <- get _sleader <- get @@ -187,9 +173,8 @@ smarkSuspect <- get scondInMelee <- get svictories <- get - sdebugCli <- get + soptions <- get let sbfsD = EM.empty - sactorAspect = EM.empty salter = EM.empty srandom = read g squit = False diff --git a/Game/LambdaHack/Client/UI.hs b/Game/LambdaHack/Client/UI.hs --- a/Game/LambdaHack/Client/UI.hs +++ b/Game/LambdaHack/Client/UI.hs @@ -2,19 +2,17 @@ -- requests, based on the client's view (visualized for the player) -- of the game state. module Game.LambdaHack.Client.UI - ( -- * Client UI monad - MonadClientUI(..) - -- * Assorted UI operations - , putSession, queryUI + ( -- * Querying the human player + queryUI + -- * UI monad and session type + , MonadClientUI(..), SessionUI(..) + -- * Updating UI state wrt game state changes , displayRespUpdAtomicUI, displayRespSfxAtomicUI - -- * Startup - , KeyKind, SessionUI(..), emptySessionUI - , Config, applyConfigToDebug, configCmdline, mkConfig - , ChanFrontend, chanFrontend, frontendShutdown - -- * Operations exposed for LoopClient - , ColorMode(..) - , reportToSlideshow, getConfirms, msgAdd, promptAdd, addPressedEsc - , tryRestore, stdBinding + -- * Startup and initialization + , KeyKind + , UIOptions, applyUIOptions, uCmdline, mkUIOptions + -- * Operations exposed for "Game.LambdaHack.Client.LoopM" + , ChanFrontend, chanFrontend, msgAdd, tryRestore, stdBinding #ifdef EXPOSE_INTERNAL -- * Internal operations , humanCommand @@ -30,35 +28,34 @@ import qualified Data.Map.Strict as M import qualified Data.Text as T -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI.Config -import Game.LambdaHack.Client.UI.Content.KeyKind -import Game.LambdaHack.Client.UI.DisplayAtomicM -import Game.LambdaHack.Client.UI.FrameM -import Game.LambdaHack.Client.UI.Frontend -import Game.LambdaHack.Client.UI.HandleHelperM -import Game.LambdaHack.Client.UI.HandleHumanM +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.Request +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI.Content.KeyKind +import Game.LambdaHack.Client.UI.DisplayAtomicM +import Game.LambdaHack.Client.UI.FrameM +import Game.LambdaHack.Client.UI.Frontend +import Game.LambdaHack.Client.UI.HandleHelperM +import Game.LambdaHack.Client.UI.HandleHumanM import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.KeyBindings -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.Msg -import Game.LambdaHack.Client.UI.MsgM -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.OverlayM -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Client.UI.Slideshow -import Game.LambdaHack.Client.UI.SlideshowM -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.ClientOptions -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Client.UI.KeyBindings +import Game.LambdaHack.Client.UI.MonadClientUI +import Game.LambdaHack.Client.UI.Msg +import Game.LambdaHack.Client.UI.MsgM +import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Client.UI.Slideshow +import Game.LambdaHack.Client.UI.SlideshowM +import Game.LambdaHack.Client.UI.UIOptions +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.State +import Game.LambdaHack.Content.ModeKind --- | Handle the move of a UI player. +-- | Handle the move of a human player. queryUI :: MonadClientUI m => m RequestUI queryUI = do side <- getsClient sside @@ -71,16 +68,16 @@ addPressedEsc -- Regaining control of faction cancels --stopAfter*. modifyClient $ \cli -> - cli {sdebugCli = (sdebugCli cli) { sstopAfterSeconds = Nothing + cli {soptions = (soptions cli) { sstopAfterSeconds = Nothing , sstopAfterFrames = Nothing }} return (ReqUIAutomate, Nothing) -- stop AI else do -- As long as UI faction is under AI control, check, once per move, -- for benchmark game stop. - stopAfterFrames <- getsClient $ sstopAfterFrames . sdebugCli + stopAfterFrames <- getsClient $ sstopAfterFrames . soptions case stopAfterFrames of Nothing -> do - stopAfterSeconds <- getsClient $ sstopAfterSeconds . sdebugCli + stopAfterSeconds <- getsClient $ sstopAfterSeconds . soptions case stopAfterSeconds of Nothing -> return (ReqUINop, Nothing) Just stopS -> do @@ -97,7 +94,7 @@ return (ReqUIGameExit, Nothing) -- ask server to exit else return (ReqUINop, Nothing) else do - let mleader = _gleader fact + let mleader = gleader fact !_A = assert (isJust mleader) () req <- humanCommand leader2 <- getLeaderUI @@ -106,16 +103,16 @@ -- | Let the human player issue commands until any command takes time. humanCommand :: forall m. MonadClientUI m => m ReqUI humanCommand = do - modifySession $ \sess -> sess {slastLost = ES.empty} - modifySession $ \sess -> sess {skeysHintMode = KeysHintAbsent} + modifySession $ \sess -> sess { slastLost = ES.empty + , skeysHintMode = KeysHintAbsent } let loop :: m ReqUI loop = do - report <- getsSession _sreport + report <- getsSession sreport if nullReport report then do -- Display keys sometimes, alternating with empty screen. keysHintMode <- getsSession skeysHintMode case keysHintMode of - KeysHintPresent -> describeMainKeys >>= promptAdd + KeysHintPresent -> promptMainKeys KeysHintBlocked -> modifySession $ \sess -> sess {skeysHintMode = KeysHintAbsent} _ -> return () @@ -134,9 +131,10 @@ void $ getConfirms ColorFull [K.spaceKM, K.escKM] slidesRaw -- Display base frame at the end. return [] - (seqCurrent, seqPrevious, k) <- getsSession slastRecord - let slastRecord | k == 0 = ([], seqCurrent, 0) - | otherwise = ([], seqCurrent ++ seqPrevious, k - 1) + LastRecord seqCurrent seqPrevious k <- getsSession slastRecord + let slastRecord + | k == 0 = LastRecord [] seqCurrent 0 + | otherwise = LastRecord [] (seqCurrent ++ seqPrevious) (k - 1) modifySession $ \sess -> sess {slastRecord} lastPlay <- getsSession slastPlay leader <- getLeaderUI diff --git a/Game/LambdaHack/Client/UI/ActorUI.hs b/Game/LambdaHack/Client/UI/ActorUI.hs --- a/Game/LambdaHack/Client/UI/ActorUI.hs +++ b/Game/LambdaHack/Client/UI/ActorUI.hs @@ -4,24 +4,24 @@ ( ActorUI(..), ActorDictUI , keySelected, partActor, partPronoun , ppContainer, ppCStore, ppCStoreIn, ppCStoreWownW - , ppContainerWownW, verbCStore, tryFindHeroK + , ppContainerWownW, verbCStore, tryFindActor, tryFindHeroK ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM -import GHC.Generics (Generic) +import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.State data ActorUI = ActorUI { bsymbol :: Char -- ^ individual map symbol @@ -88,7 +88,6 @@ verbCStore CInv = "pack" verbCStore CSha = "stash" --- | Tries to finds an actor body satisfying a predicate on any level. tryFindActor :: State -> (ActorId -> Actor -> Bool) -> Maybe (ActorId, Actor) tryFindActor s p = find (uncurry p) $ EM.assocs $ sactorD s diff --git a/Game/LambdaHack/Client/UI/Animation.hs b/Game/LambdaHack/Client/UI/Animation.hs --- a/Game/LambdaHack/Client/UI/Animation.hs +++ b/Game/LambdaHack/Client/UI/Animation.hs @@ -2,14 +2,18 @@ module Game.LambdaHack.Client.UI.Animation ( Animation, renderAnim , pushAndDelay, blinkColorActor, twirlSplash, blockHit, blockMiss - , deathBody, shortDeathBody, actorX, swapPlaces, teleport, fadeout + , deathBody, shortDeathBody, actorX, teleport, swapPlaces, fadeout +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , blank, cSym, mapPosToOffset, mzipSingleton, mzipPairs +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Bits +import Data.Bits import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Client.UI.Frame @@ -21,15 +25,17 @@ -- | Animation is a list of frame modifications to play one by one, -- where each modification if a map from positions to level map symbols. -newtype Animation = Animation [Overlay] +newtype Animation = Animation [IntOverlay] deriving (Eq, Show) -- | Render animations on top of a screen frame. +-- +-- Located in this module to keep @Animation@ abstract. renderAnim :: FrameForall -> Animation -> Frames renderAnim basicFrame (Animation anim) = - let modifyFrame :: Overlay -> FrameForall + let modifyFrame :: IntOverlay -> FrameForall modifyFrame am = overlayFrame am basicFrame - modifyFrames :: (Overlay, Overlay) -> Maybe FrameForall + modifyFrames :: (IntOverlay, IntOverlay) -> Maybe FrameForall modifyFrames (am, amPrevious) = if am == amPrevious then Nothing else Just $ modifyFrame am in Just basicFrame : map modifyFrames (zip anim ([] : anim)) @@ -45,13 +51,13 @@ let lxsize = fst normalLevelBound + 1 in ((py + 1) * lxsize + px, [attr]) -mzipSingleton :: Point -> Maybe AttrCharW32 -> Overlay +mzipSingleton :: Point -> Maybe AttrCharW32 -> IntOverlay mzipSingleton p1 mattr1 = map mapPosToOffset $ let mzip (pos, mattr) = fmap (\attr -> (pos, attr)) mattr in catMaybes [mzip (p1, mattr1)] mzipPairs :: (Point, Point) -> (Maybe AttrCharW32, Maybe AttrCharW32) - -> Overlay + -> IntOverlay mzipPairs (p1, p2) (mattr1, mattr2) = map mapPosToOffset $ let mzip (pos, mattr) = fmap (\attr -> (pos, attr)) mattr in catMaybes $ if p1 /= p2 diff --git a/Game/LambdaHack/Client/UI/Config.hs b/Game/LambdaHack/Client/UI/Config.hs deleted file mode 100644 --- a/Game/LambdaHack/Client/UI/Config.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE DeriveGeneric, FlexibleContexts #-} --- | Personal game configuration file type definitions. -module Game.LambdaHack.Client.UI.Config - ( Config(..), mkConfig, applyConfigToDebug - ) where - -import Prelude () - -import Game.LambdaHack.Common.Prelude - -import Control.DeepSeq -import Data.Binary -import qualified Data.Ini as Ini -import qualified Data.Ini.Reader as Ini -import qualified Data.Ini.Types as Ini -import qualified Data.Map.Strict as M -import Game.LambdaHack.Common.ClientOptions -import GHC.Generics (Generic) -import System.FilePath -import Text.Read - -import Game.LambdaHack.Client.UI.HumanCmd -import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Common.File -import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Content.RuleKind - --- | Fully typed contents of the UI config file. This config --- is a part of a game client. -data Config = Config - { -- commands - configCommands :: [(K.KM, CmdTriple)] - -- hero names - , configHeroNames :: [(Int, (Text, Text))] - -- ui - , configVi :: Bool -- ^ the option for Vi keys takes precendence - , configLaptop :: Bool -- ^ because the laptop keys are the default - , configGtkFontFamily :: Text - , configSdlFontFile :: Text - , configSdlTtfSizeAdd :: Int - , configSdlFonSizeAdd :: Int - , configFontSize :: Int - , configColorIsBold :: Bool - , configHistoryMax :: Int - , configMaxFps :: Int - , configNoAnim :: Bool - , configRunStopMsgs :: Bool - , configCmdline :: [String] - } - deriving (Show, Generic) - -instance NFData Config - -instance Binary Config - -parseConfig :: Ini.Config -> Config -parseConfig cfg = - let configCommands = - let mkCommand (ident, keydef) = - case stripPrefix "Cmd_" ident of - Just _ -> - let (key, def) = read keydef - in (K.mkKM key, def :: CmdTriple) - Nothing -> error $ "wrong macro id" `showFailure` ident - section = Ini.allItems "extra_commands" cfg - in map mkCommand section - configHeroNames = - let toNumber (ident, nameAndPronoun) = - case stripPrefix "HeroName_" ident of - Just n -> (read n, read nameAndPronoun) - Nothing -> error $ "wrong hero name id" `showFailure` ident - section = Ini.allItems "hero_names" cfg - in map toNumber section - getOption :: forall a. Read a => String -> a - getOption optionName = - let lookupFail :: forall b. String -> b - lookupFail err = - error $ "config file access failed" - `showFailure` (err, optionName, cfg) - s = fromMaybe (lookupFail "") $ Ini.getOption "ui" optionName cfg - in either lookupFail id $ readEither s - configVi = getOption "movementViKeys_hjklyubn" - -- The option for Vi keys takes precendence, - -- because the laptop keys are the default. - configLaptop = not configVi && getOption "movementLaptopKeys_uk8o79jl" - configGtkFontFamily = getOption "gtkFontFamily" - configSdlFontFile = getOption "sdlFontFile" - configSdlTtfSizeAdd = getOption "sdlTtfSizeAdd" - configSdlFonSizeAdd = getOption "sdlFonSizeAdd" - configFontSize = getOption "fontSize" - configColorIsBold = getOption "colorIsBold" - configHistoryMax = getOption "historyMax" - configMaxFps = max 1 $ getOption "maxFps" - configNoAnim = getOption "noAnim" - configRunStopMsgs = getOption "runStopMsgs" - configCmdline = words $ getOption "overrideCmdline" - in Config{..} - --- | Read and parse UI config file. -mkConfig :: Kind.COps -> Bool -> IO Config -mkConfig Kind.COps{corule} benchmark = do - let stdRuleset = Kind.stdRuleset corule - cfgUIName = rcfgUIName stdRuleset - sUIDefault = rcfgUIDefault stdRuleset - cfgUIDefault = either (error . ("" `showFailure`)) id - $ Ini.parse sUIDefault - dataDir <- appDataDir - let userPath = dataDir cfgUIName - cfgUser <- if benchmark then return Ini.emptyConfig else do - cpExists <- doesFileExist userPath - if not cpExists - then return Ini.emptyConfig - else do - sUser <- readFile userPath - return $! either (error . ("" `showFailure`)) id $ Ini.parse sUser - let cfgUI = M.unionWith M.union cfgUser cfgUIDefault -- user cfg preferred - conf = parseConfig cfgUI - -- Catch syntax errors in complex expressions ASAP, - return $! deepseq conf conf - -applyConfigToDebug :: Kind.COps -> Config -> DebugModeCli -> DebugModeCli -applyConfigToDebug Kind.COps{corule} sconfig sdebugCli = - let stdRuleset = Kind.stdRuleset corule - in (\dbg -> dbg {sgtkFontFamily = - sgtkFontFamily dbg `mplus` Just (configGtkFontFamily sconfig)}) . - (\dbg -> dbg {sdlFontFile = - sdlFontFile dbg `mplus` Just (configSdlFontFile sconfig)}) . - (\dbg -> dbg {sdlTtfSizeAdd = - sdlTtfSizeAdd dbg `mplus` Just (configSdlTtfSizeAdd sconfig)}) . - (\dbg -> dbg {sdlFonSizeAdd = - sdlFonSizeAdd dbg `mplus` Just (configSdlFonSizeAdd sconfig)}) . - (\dbg -> dbg {sfontSize = - sfontSize dbg `mplus` Just (configFontSize sconfig)}) . - (\dbg -> dbg {scolorIsBold = - scolorIsBold dbg `mplus` Just (configColorIsBold sconfig)}) . - (\dbg -> dbg {smaxFps = - smaxFps dbg `mplus` Just (configMaxFps sconfig)}) . - (\dbg -> dbg {snoAnim = - snoAnim dbg `mplus` Just (configNoAnim sconfig)}) . - (\dbg -> dbg {stitle = - stitle dbg `mplus` Just (rtitle stdRuleset)}) . - (\dbg -> dbg {sfontDir = - sfontDir dbg `mplus` Just (rfontDir stdRuleset)}) - $ sdebugCli diff --git a/Game/LambdaHack/Client/UI/Content/KeyKind.hs b/Game/LambdaHack/Client/UI/Content/KeyKind.hs --- a/Game/LambdaHack/Client/UI/Content/KeyKind.hs +++ b/Game/LambdaHack/Client/UI/Content/KeyKind.hs @@ -1,12 +1,17 @@ --- | The type of key-command mappings to be used for the UI. +-- | The type of definitions of key-command mappings to be used for the UI +-- and shorthands for specifying command triples in the content files. module Game.LambdaHack.Client.UI.Content.KeyKind ( KeyKind(..), evalKeyDef , addCmdCategory, replaceDesc, moveItemTriple, repeatTriple , mouseLMB, mouseMMB, mouseRMB , goToCmd, runToAllCmd, autoexploreCmd, autoexplore25Cmd - , aimFlingCmd, projectI, projectA, flingTs, applyI, applyIK + , aimFlingCmd, projectI, projectA, flingTs, applyIK, applyI , grabItems, dropItems, descTs, defaultHeroSelect - ) where +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , replaceCmd, projectICmd, grabCmd, dropCmd +#endif + ) where import Prelude () @@ -15,15 +20,13 @@ import qualified Data.Char as Char import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Client.UI.ActorUI (verbCStore) -import Game.LambdaHack.Client.UI.HumanCmd +import Game.LambdaHack.Client.UI.ActorUI (verbCStore) +import Game.LambdaHack.Client.UI.HumanCmd import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Misc --- | Key-command mappings to be used for the UI. -newtype KeyKind = KeyKind - { rhumanCommands :: [(K.KM, CmdTriple)] -- ^ default client UI commands - } +-- | Key-command mappings to be specified in content and used for the UI. +newtype KeyKind = KeyKind [(K.KM, CmdTriple)] -- ^ default client UI commands evalKeyDef :: (String, CmdTriple) -> (K.KM, CmdTriple) evalKeyDef (t, triple@(cats, _, _)) = diff --git a/Game/LambdaHack/Client/UI/DisplayAtomicM.hs b/Game/LambdaHack/Client/UI/DisplayAtomicM.hs --- a/Game/LambdaHack/Client/UI/DisplayAtomicM.hs +++ b/Game/LambdaHack/Client/UI/DisplayAtomicM.hs @@ -1,6 +1,13 @@ -- | Display atomic commands received by the client. module Game.LambdaHack.Client.UI.DisplayAtomicM ( displayRespUpdAtomicUI, displayRespSfxAtomicUI +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , updateItemSlot, markDisplayNeeded, updateItemSlotSide, lookAtMove + , actorVerbMU, aidVerbMU, itemVerbMU, itemAidVerbMU, msgDuplicateScrap + , createActorUI, destroyActorUI, spotItem, moveActor, displaceActorUI + , moveItemUI, quitFactionUI, discover, ppSfxMsg, setLastSlot, strike +#endif ) where import Prelude () @@ -10,59 +17,59 @@ import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES +import Data.Key (mapWithKeyM_) import qualified Data.Map.Strict as M -import Data.Tuple -import GHC.Exts (inline) +import Data.Tuple +import GHC.Exts (inline) import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Atomic -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI.ActorUI -import Game.LambdaHack.Client.UI.Animation -import Game.LambdaHack.Client.UI.Config -import Game.LambdaHack.Client.UI.FrameM -import Game.LambdaHack.Client.UI.HandleHelperM -import Game.LambdaHack.Client.UI.ItemDescription -import Game.LambdaHack.Client.UI.ItemSlot +import Game.LambdaHack.Atomic +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI.ActorUI +import Game.LambdaHack.Client.UI.Animation +import Game.LambdaHack.Client.UI.FrameM +import Game.LambdaHack.Client.UI.HandleHelperM +import Game.LambdaHack.Client.UI.ItemDescription +import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.Msg -import Game.LambdaHack.Client.UI.MsgM -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.OverlayM -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Client.UI.Slideshow -import Game.LambdaHack.Client.UI.SlideshowM -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Client.UI.MonadClientUI +import Game.LambdaHack.Client.UI.Msg +import Game.LambdaHack.Client.UI.MsgM +import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Client.UI.Slideshow +import Game.LambdaHack.Client.UI.SlideshowM +import Game.LambdaHack.Client.UI.UIOptions +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Flavour -import Game.LambdaHack.Common.Item +import qualified Game.LambdaHack.Common.Dice as Dice +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Flavour +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile +import Game.LambdaHack.Common.Time import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.RuleKind +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Content.TileKind as TK -- * RespUpdAtomicUI --- | Visualize atomic actions sent to the client. This is done +-- | Visualize atomic updates sent to the client. This is done -- in the global state after the command is executed and after -- the client state is modified by the command. -displayRespUpdAtomicUI :: MonadClientUI m - => Bool -> StateClient -> UpdAtomic -> m () +displayRespUpdAtomicUI :: MonadClientUI m => Bool -> UpdAtomic -> m () {-# INLINE displayRespUpdAtomicUI #-} -displayRespUpdAtomicUI verbose oldCli cmd = case cmd of +displayRespUpdAtomicUI verbose cmd = case cmd of -- Create/destroy actors and items. UpdCreateActor aid body _ -> createActorUI True aid body UpdDestroyActor aid body _ -> destroyActorUI True aid body @@ -88,7 +95,7 @@ ownerFun <- partActorLeaderFun let wown = ppContainerWownW ownerFun True c itemVerbMU iid kit (MU.Text $ makePhrase $ "appear" : wown) c - mleader <- getsClient _sleader + mleader <- getsClient sleader when (Just aid == mleader) $ modifySession $ \sess -> sess {slastSlot} CEmbed lid _ -> markDisplayNeeded lid @@ -106,48 +113,11 @@ markDisplayNeeded lid UpdSpotActor aid body _ -> createActorUI False aid body UpdLoseActor aid body _ -> destroyActorUI False aid body - UpdSpotItem verbose2 iid _ kit c -> do - -- This is due to a move, or similar, which will be displayed, - -- so no extra @markDisplayNeeded@ needed here and in similar places. - ItemSlots itemSlots _ <- getsSession sslots - case lookup iid $ map swap $ EM.assocs itemSlots of - Nothing -> -- never seen or would have a slot - case c of - CActor aid store -> - -- Most probably an actor putting item in or out of shared stash. - void $ updateItemSlotSide store aid iid - CEmbed{} -> return () - CFloor lid p -> do - void $ updateItemSlot CGround Nothing iid - sxhairOld <- getsSession sxhair - case sxhairOld of - TEnemy{} -> return () -- probably too important to overwrite - TPoint TEnemyPos{} _ _ -> return () - _ -> do - -- Don't steal xhair if it's only an item on another level. - -- For enemies, OTOH, capture xhair to alarm player. - lidV <- viewedLevelUI - when (lid == lidV) $ do - bag <- getsState $ getFloorBag lid p - modifySession $ \sess -> - sess {sxhair = TPoint (TItem bag) lidV p} - itemVerbMU iid kit "be spotted" c - stopPlayBack - CTrunk{} -> return () - _ -> return () -- seen already (has a slot assigned) - when verbose2 $ case c of - CActor aid store | store `elem` [CEqp, CInv] -> do - -- Actor fetching an item from shared stash, most probably. - bUI <- getsSession $ getActorUI aid - subject <- partActorLeader aid bUI - let ownW = ppCStoreWownW False store subject - verb = MU.Text $ makePhrase $ "be added to" : ownW - itemVerbMU iid kit verb c - _ -> return () + UpdSpotItem verbose2 iid _ kit c -> spotItem verbose2 iid kit c + {- UpdLoseItem False _ _ _ _ -> return () -- The message is rather cryptic, so let's disable it until it's decided -- if anemy inventories should be displayed, etc. - {- UpdLoseItem True iid _ kit c@(CActor aid store) | store /= CSha -> do -- Actor putting an item into shared stash, most probably. side <- getsClient sside @@ -158,6 +128,9 @@ when (bfid b == side) $ itemVerbMU iid kit verb c -} UpdLoseItem{} -> return () + UpdSpotItemBag c bag _ -> + mapWithKeyM_ (\iid kit -> spotItem True iid kit c) bag + UpdLoseItemBag{} -> return () -- Move actors and items. UpdMoveActor aid source target -> moveActor aid source target UpdWaitActor aid _ -> when verbose $ aidVerbMU aid "wait" @@ -196,11 +169,9 @@ | otherwise -> do when (n >= bhp b && bhp b > 0) $ actorVerbMU aid bUI "return from the brink of death" - mleader <- getsClient _sleader + mleader <- getsClient sleader when (Just aid == mleader) $ do - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` aid) - (EM.lookup aid actorAspect) + ar <- getsState $ getActorAspect aid -- Regenerating actors never stop gaining HP, so we need to stop -- reporting it after they reach full HP for the first time. when (bhp b >= xM (aMaxHP ar) && bhp b - n < xM (aMaxHP ar)) $ do @@ -226,26 +197,26 @@ -- Change faction attributes. UpdQuitFaction fid _ toSt -> quitFactionUI fid toSt UpdLeadFaction fid (Just source) (Just target) -> do - side <- getsClient sside - when (fid == side) $ do - fact <- getsState $ (EM.! side) . sfactionD - lidV <- viewedLevelUI - when (isAIFact fact) $ markDisplayNeeded lidV - -- This faction can't run with multiple actors, so this is not - -- a leader change while running, but rather server changing - -- their leader, which the player should be alerted to. - when (noRunWithMulti fact) stopPlayBack - actorD <- getsState sactorD - case EM.lookup source actorD of - Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do - -- Regardless who the leader is, give proper names here, not 'you'. - sbUI <- getsSession $ getActorUI source - tbUI <- getsSession $ getActorUI target - let subject = partActor tbUI - object = partActor sbUI - msgAdd $ makeSentence [ MU.SubjectVerbSg subject "take command" - , "from", object ] - _ -> return () + fact <- getsState $ (EM.! fid) . sfactionD + lidV <- viewedLevelUI + when (isAIFact fact) $ markDisplayNeeded lidV + -- This faction can't run with multiple actors, so this is not + -- a leader change while running, but rather server changing + -- their leader, which the player should be alerted to. + when (noRunWithMulti fact) stopPlayBack + actorD <- getsState sactorD + case EM.lookup source actorD of + Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do + -- Regardless who the leader is, give proper names here, not 'you'. + sbUI <- getsSession $ getActorUI source + tbUI <- getsSession $ getActorUI target + let subject = partActor tbUI + object = partActor sbUI + msgAdd $ makeSentence [ MU.SubjectVerbSg subject "take command" + , "from", object ] + _ -> return () + lookAtMove target + UpdLeadFaction _ Nothing (Just target) -> lookAtMove target UpdLeadFaction{} -> return () UpdDiplFaction fid1 fid2 _ toDipl -> do name1 <- getsState $ gname . (EM.! fid1) . sfactionD @@ -263,23 +234,41 @@ when (fid == side) $ setFrontAutoYes b UpdRecordKill{} -> return () -- Alter map. - UpdAlterTile lid _ _ _ -> markDisplayNeeded lid + UpdAlterTile lid p fromTile toTile -> do + markDisplayNeeded lid + Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops + let feats = TK.tfeature $ okind fromTile + toAlter feat = + case feat of + TK.OpenTo tgroup -> Just tgroup + TK.CloseTo tgroup -> Just tgroup + TK.ChangeTo tgroup -> Just tgroup + _ -> Nothing + groupsToAlterTo = mapMaybe toAlter feats + freq = map fst $ filter (\(_, q) -> q > 0) $ TK.tfreq $ okind toTile + when (null $ intersect freq groupsToAlterTo) $ do + -- Player notices @fromTile can't be altered into @toTIle@, + -- which is uncanny, so we produce a message. + -- This happens when the player missed an earlier search of the tile + -- performed by another faction. + let subject = "" -- a hack, we we don't handle adverbs well + verb = "turn into" + msg = makeSentence [ "the", MU.Text $ TK.tname $ okind fromTile + , "at position", MU.Text $ tshow p + , "suddenly" -- adverb + , MU.SubjectVerbSg subject verb + , MU.AW $ MU.Text $ TK.tname $ okind toTile ] + msgAdd msg UpdAlterExplorable{} -> return () - UpdSearchTile aid p toTile -> do + UpdSearchTile aid _p toTile -> do Kind.COps{cotile = cotile@Kind.Ops{okind}} <- getsState scops - b <- getsState $ getActorBody aid - lvl <- getLevel $ blid b subject <- partAidLeader aid - let t = lvl `at` p - fromTile = Tile.hideAs cotile toTile - verb | t == toTile = "confirm" - | otherwise = "reveal" + let fromTile = fromJust $ Tile.hideAs cotile toTile subject2 = MU.Text $ TK.tname $ okind fromTile - verb2 = "be" object = MU.Text $ TK.tname $ okind toTile - let msg = makeSentence [ MU.SubjectVerbSg subject verb + let msg = makeSentence [ MU.SubjectVerbSg subject "reveal" , "that the" - , MU.SubjectVerbSg subject2 verb2 + , MU.SubjectVerbSg subject2 "be" , MU.AW object ] unless (subject2 == object) $ msgAdd msg UpdHideTile{} -> return () @@ -292,25 +281,18 @@ UpdTimeItem{} -> return () UpdAgeGame{} -> do sdisplayNeeded <- getsSession sdisplayNeeded - when sdisplayNeeded $ do - -- Push the frame depicting the current level to the frame queue. - -- Only one line of the report is shown, as in animations, - -- because it may not be our turn, so we can't clear the message - -- to see what is underneath. - lidV <- viewedLevelUI - report <- getReportUI - let truncRep = [renderReport report] - frame <- drawOverlay ColorFull False truncRep lidV - displayFrames lidV [Just frame] + when sdisplayNeeded pushFrame UpdUnAgeGame{} -> return () - UpdDiscover c iid _ _ -> discover c oldCli iid + UpdDiscover c iid _ _ -> discover c iid UpdCover{} -> return () -- don't spam when doing undo - UpdDiscoverKind c iid _ -> discover c oldCli iid + UpdDiscoverKind{} -> return () -- don't spam when server tweaks stuff UpdCoverKind{} -> return () -- don't spam when doing undo - UpdDiscoverSeed c iid _ -> discover c oldCli iid + UpdDiscoverSeed{} -> return () -- don't spam when server tweaks stuff UpdCoverSeed{} -> return () -- don't spam when doing undo + UpdDiscoverServer{} -> error "server command leaked to client" + UpdCoverServer{} -> error "server command leaked to client" UpdPerception{} -> return () - UpdRestart fid _ _ _ _ _ -> do + UpdRestart fid _ _ _ _ -> do sstart <- getsSession sstart when (sstart == 0) resetSessionStart history <- getsSession shistory @@ -319,9 +301,11 @@ let title = rtitle $ Kind.stdRuleset corule msgAdd $ "Welcome to" <+> title <> "!" -- Generate initial history. Only for UI clients. - sconfig <- getsSession sconfig - shistory <- defaultHistory $ configHistoryMax sconfig + sUIOptions <- getsSession sUIOptions + shistory <- defaultHistory $ uHistoryMax sUIOptions modifySession $ \sess -> sess {shistory} + lid <- getArenaUI + lvl <- getLevel lid mode <- getGameMode curChal <- getsClient scurChal fact <- getsState $ (EM.! fid) . sfactionD @@ -329,7 +313,8 @@ [] -> True [(_, 1, _)] -> True _ -> False - msgAdd $ "New game started in" <+> mname mode <+> "mode." <+> mdesc mode + msgAdd $ "New game started in" <+> mname mode <+> "mode." + <+> mdesc mode <+> ldesc lvl <+> if cwolf curChal && not loneMode then "Being a lone wolf, you start without companions." else "" @@ -345,8 +330,11 @@ fact <- getsState $ (EM.! fid) . sfactionD setFrontAutoYes $ isAIFact fact unless (isAIFact fact) $ do + lid <- getArenaUI + lvl <- getLevel lid mode <- getGameMode - promptAdd $ "Continuing" <+> mname mode <> "." <+> mdesc mode + promptAdd $ "Continuing" <+> mname mode <> "." + <+> mdesc mode <+> ldesc lvl <+> "Are you up for the challenge?" slides <- reportToSlideshow [K.spaceKM, K.escKM] km <- getConfirms ColorFull [K.spaceKM, K.escKM] slides @@ -354,10 +342,6 @@ UpdResumeServer{} -> return () UpdKillExit{} -> frontendShutdown UpdWriteSave -> when verbose $ promptAdd "Saving backup." - UpdMsgAll "SortSlots" -> do -- hack - side <- getsClient sside - sortSlots side Nothing - UpdMsgAll msg -> msgAdd msg updateItemSlot :: MonadClientUI m => CStore -> Maybe ActorId -> ItemId -> m SlotChar @@ -391,8 +375,7 @@ markDisplayNeeded :: MonadClientUI m => LevelId -> m () markDisplayNeeded lid = do lidV <- viewedLevelUI - when (lidV == lid) $ - modifySession $ \sess -> sess {sdisplayNeeded = True} + when (lidV == lid) $ modifySession $ \sess -> sess {sdisplayNeeded = True} updateItemSlotSide :: MonadClientUI m => CStore -> ActorId -> ItemId -> m SlotChar @@ -424,7 +407,6 @@ adjOur = filter our adjacentAssocs unless (null adjOur) stopPlayBack --- | Sentences such as \"Dog barks loudly.\". actorVerbMU :: MonadClientUI m => ActorId -> ActorUI -> MU.Part -> m () actorVerbMU aid bUI verb = do subject <- partActorLeader aid bUI @@ -440,7 +422,7 @@ itemVerbMU iid kit@(k, _) verb c = assert (k > 0) $ do lid <- getsState $ lidFromC c localTime <- getsState $ getLocalTime lid - itemToF <- itemToFullClient + itemToF <- getsState itemToFull side <- getsClient sside factionD <- getsState sfactionD let subject = partItemWs side factionD @@ -464,7 +446,7 @@ case iid `EM.lookup` bag of Nothing -> error $ "" `showFailure` (aid, verb, iid, cstore) Just kit@(k, _) -> do - itemToF <- itemToFullClient + itemToF <- getsState itemToFull let lid = blid body localTime <- getsState $ getLocalTime lid subject <- partAidLeader aid @@ -488,7 +470,7 @@ msgDuplicateScrap :: MonadClientUI m => m Bool msgDuplicateScrap = do - report <- getsSession _sreport + report <- getsSession sreport history <- getsSession shistory let (lastMsg, repRest) = lastMsgOfReport report repLast = lastReportOfHistory history @@ -508,12 +490,14 @@ createActorUI born aid body = do side <- getsClient sside fact <- getsState $ (EM.! bfid body) . sfactionD + globalTime <- getsState stime + localTime <- getsState $ getLocalTime $ blid body mbUI <- getsSession $ EM.lookup aid . sactorUI bUI <- case mbUI of Just bUI -> return bUI Nothing -> do trunk <- getsState $ getItemBody $ btrunk body - Config{configHeroNames} <- getsSession sconfig + UIOptions{uHeroNames} <- getsSession sUIOptions let isBlast = actorTrunkIsBlast trunk baseColor = flavourToColor $ jflavour trunk basePronoun | not (bproj body) && fhasGender (gplayer fact) = "he" @@ -525,7 +509,7 @@ if gcolor fact /= Color.BrWhite then (nameFromNumber (fname $ gplayer fact) k, "he") else fromMaybe (nameFromNumber (fname $ gplayer fact) k, "he") - $ lookup k configHeroNames + $ lookup k uHeroNames (n, bsymbol) <- if | bproj body -> return (0, if isBlast then jsymbol trunk else '*') | baseColor /= Color.BrWhite -> return (0, jsymbol trunk) @@ -538,7 +522,6 @@ n = fromJust $ elemIndex False mhs return (n, if 0 < n && n < 10 then Char.intToDigit n else '@') factionD <- getsState sfactionD - localTime <- getsState $ getLocalTime $ blid body let (bname, bpronoun) = if | bproj body -> let adj | length (btrajectory body) < 5 = "falling" @@ -558,10 +541,12 @@ modifySession $ \sess -> sess {sactorUI = EM.insert aid bUI $ sactorUI sess} return bUI - let verb = if born - then MU.Text $ "appear" - <+> if bfid body == side then "" else "suddenly" - else "be spotted" + let verb = MU.Text $ + if born + then if globalTime == timeZero + then "be here" + else "appear" <+> if bfid body == side then "" else "suddenly" + else "be spotted" mapM_ (\(iid, store) -> void $ updateItemSlotSide store aid iid) (getCarriedIidCStore body) when (bfid body /= side) $ do @@ -582,7 +567,6 @@ else do actorVerbMU aid bUI verb animate (blid body) $ actorX (bpos body) - lookAtMove aid destroyActorUI :: MonadClientUI m => Bool -> ActorId -> Actor -> m () destroyActorUI destroy aid b = do @@ -613,7 +597,7 @@ modifySession $ \sess -> sess {sselected = upd $ sselected sess} when destroy $ do displayMore ColorBW "Alas!" - mleader <- getsClient _sleader + mleader <- getsClient sleader when (isJust mleader) -- This is especially handy when the dead actor was a leader -- on a different level than the new one: @@ -621,6 +605,48 @@ -- If pushed, animate spotting again, to draw attention to pushing. markDisplayNeeded (blid b) +spotItem :: MonadClientUI m + => Bool -> ItemId -> ItemQuant -> Container -> m () +spotItem verbose iid kit c = do + -- This is due to a move, or similar, which will be displayed, + -- so no extra @markDisplayNeeded@ needed here and in similar places. + ItemSlots itemSlots _ <- getsSession sslots + case lookup iid $ map swap $ EM.assocs itemSlots of + Nothing -> -- never seen or would have a slot + case c of + CActor aid store -> + -- Most probably an actor putting item in or out of shared stash. + void $ updateItemSlotSide store aid iid + CEmbed{} -> return () + CFloor lid p -> do + void $ updateItemSlot CGround Nothing iid + sxhairOld <- getsSession sxhair + case sxhairOld of + TEnemy{} -> return () -- probably too important to overwrite + TPoint TEnemyPos{} _ _ -> return () + _ -> do + -- Don't steal xhair if it's only an item on another level. + -- For enemies, OTOH, capture xhair to alarm player. + lidV <- viewedLevelUI + when (lid == lidV) $ do + bag <- getsState $ getFloorBag lid p + modifySession $ \sess -> + sess {sxhair = TPoint (TItem bag) lidV p} + itemVerbMU iid kit "be spotted" c + stopPlayBack + CTrunk{} -> return () + _ -> return () -- this item or another with the same @iid@ + -- seen already (has a slot assigned), so old news + when verbose $ case c of + CActor aid store | store `elem` [CEqp, CInv, CGround, CSha] -> do + -- Actor fetching an item from or to shared stash, most probably. + bUI <- getsSession $ getActorUI aid + subject <- partActorLeader aid bUI + let ownW = ppCStoreWownW False store subject + verb = MU.Text $ makePhrase $ "be added to" : ownW + itemVerbMU iid kit verb c + _ -> return () + moveActor :: MonadClientUI m => ActorId -> Point -> Point -> m () moveActor aid source target = do -- If source and target tile distant, assume it's a teleportation @@ -661,7 +687,7 @@ b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD let underAI = isAIFact fact - mleader <- getsClient _sleader + mleader <- getsClient sleader ItemSlots itemSlots _ <- getsSession sslots case lookup iid $ map swap $ EM.assocs itemSlots of Just slastSlot -> do @@ -752,7 +778,7 @@ sli <- overlayToSlideshow (lysize + 1) [K.spaceKM, K.escKM] io return (bag, sli, tot) localTime <- getsState $ getLocalTime arena - itemToF <- itemToFullClient + itemToF <- getsState itemToFull ItemSlots lSlots _ <- getsSession sslots let keyOfEKM (Left km) = km keyOfEKM (Right SlotChar{slotChar}) = [K.mkChar slotChar] @@ -806,15 +832,13 @@ fadeOutOrIn True _ -> return () -discover :: MonadClientUI m => Container -> StateClient -> ItemId -> m () -discover c oldCli iid = do - let StateClient{sdiscoKind=oldDiscoKind, sdiscoAspect=oldDiscoAspect} = oldCli - cstore = storeFromC c +discover :: MonadClientUI m => Container -> ItemId -> m () +discover c iid = do + let cstore = storeFromC c lid <- getsState $ lidFromC c - discoKind <- getsClient sdiscoKind - discoAspect <- getsClient sdiscoAspect + globalTime <- getsState stime localTime <- getsState $ getLocalTime lid - itemToF <- itemToFullClient + itemToF <- getsState itemToFull bag <- getsState $ getContainerBag c side <- getsClient sside factionD <- getsState sfactionD @@ -839,14 +863,10 @@ namePhrase = MU.Phrase $ [secretName, secretAEText] ++ nameWhere msg = makeSentence ["the", MU.SubjectVerbSg namePhrase "turn out to be", knownName] - jix = jkindIx $ itemBase itemFull - ik = itemKind $ fromJust $ itemDisco itemFull -- Compare descriptions of all aspects and effects to determine -- if the discovery was meaningful to the player. - unless (isOurOrgan - || (EM.member jix discoKind == EM.member jix oldDiscoKind - && (EM.member iid discoAspect == EM.member iid oldDiscoAspect - || not (aspectsRandom ik)))) $ + unless (globalTime == timeZero -- don't spam about initial equipment + || isOurOrgan) $ -- assume own faction organs known intuitively msgAdd msg -- * RespSfxAtomicUI @@ -949,26 +969,36 @@ msgAdd $ makeSentence [MU.SubjectVerbSg subject verb, MU.Text fidSourceName, "control"] stopPlayBack - IK.Impress -> actorVerbMU aid bUI $ "be awestruck" + IK.Impress -> actorVerbMU aid bUI "be awestruck" IK.Summon grp p -> do let verb = if bproj b then "lure" else "summon" - object = if p == 1 - then MU.Text $ tshow grp - else MU.Ws $ MU.Text $ tshow grp -- avoid "1 + dl 3" + object = (if p == 1 -- avoid "2 + 4 dl 3" + then MU.AW + else MU.Ws) $ MU.Text $ tshow grp actorVerbMU aid bUI $ MU.Phrase [verb, object] - IK.Ascend True -> actorVerbMU aid bUI "find a way upstairs" - IK.Ascend False -> actorVerbMU aid bUI "find a way downstairs" + IK.Ascend True -> do + actorVerbMU aid bUI "find a way upstairs" + (lid, _) <- getsState $ whereTo (blid b) (bpos b) (Just True) + . sdungeon + lvl <- getLevel lid + msgAdd $ ldesc lvl + IK.Ascend False -> do + actorVerbMU aid bUI "find a way downstairs" + (lid, _) <- getsState $ whereTo (blid b) (bpos b) (Just False) + . sdungeon + lvl <- getLevel lid + msgAdd $ ldesc lvl IK.Escape{} -> return () IK.Paralyze{} -> actorVerbMU aid bUI "be paralyzed" IK.InsertMove{} -> actorVerbMU aid bUI "act with extreme speed" - IK.Teleport t | t <= 8 -> actorVerbMU aid bUI "blink" + IK.Teleport t | Dice.maxDice t <= 9 -> actorVerbMU aid bUI "blink" IK.Teleport{} -> actorVerbMU aid bUI "teleport" IK.CreateItem{} -> return () IK.DropItem _ _ COrgan _ -> return () IK.DropItem{} -> actorVerbMU aid bUI "be stripped" IK.PolyItem -> do localTime <- getsState $ getLocalTime $ blid b - allAssocs <- fullAssocsClient aid [CGround] + allAssocs <- getsState $ fullAssocs aid [CGround] case allAssocs of [] -> return () -- invisible items? (_, ItemFull{..}) : _ -> do @@ -983,7 +1013,7 @@ [ MU.SubjectVerbSg subject verb , "the", secretName, secretAEText, store ] IK.Identify -> do - allAssocs <- fullAssocsClient aid [CGround] + allAssocs <- getsState $ fullAssocs aid [CGround] case allAssocs of [] -> return () -- invisible items? (_, ItemFull{..}) : _ -> do @@ -1026,8 +1056,9 @@ IK.Temporary t -> actorVerbMU aid bUI $ MU.Text t IK.Unique -> error $ "" `showFailure` sfx IK.Periodic -> error $ "" `showFailure` sfx + IK.Composite{} -> error $ "" `showFailure` sfx SfxMsgFid _ sfxMsg -> do - mleader <- getsClient _sleader + mleader <- getsClient sleader case mleader of Just{} -> return () -- will display stuff when leader moves Nothing -> do @@ -1036,6 +1067,9 @@ recordHistory msg <- ppSfxMsg sfxMsg msgAdd msg + SfxSortSlots -> do + side <- getsClient sside + sortSlots side Nothing ppSfxMsg :: MonadClientUI m => SfxMsg -> m Text ppSfxMsg sfxMsg = case sfxMsg of @@ -1101,8 +1135,7 @@ return $! makeSentence [MU.SubjectVerbSg subject verb] SfxEscapeImpossible -> return "This faction doesn't want to escape outside." SfxTransImpossible -> return "Translocation not possible." - SfxIdentifyNothing store -> return $! - "Nothing to identify" <+> ppCStoreIn store <> "." + SfxIdentifyNothing -> return "Nothing to identify." SfxPurposeNothing store -> return $! "The purpose of repurpose cannot be availed without an item" <+> ppCStoreIn store <> "." @@ -1117,18 +1150,18 @@ aidPhrase <- partActorLeader aid bUI factionD <- getsState sfactionD localTime <- getsState $ getLocalTime (blid b) - itemToF <- itemToFullClient + itemToF <- getsState itemToFull let itemFull = itemToF iid (1, []) (_, _, name, stats) = partItem (bfid b) factionD cstore localTime itemFull storeOwn = ppCStoreWownW True cstore aidPhrase - cond = if jsymbol (itemBase itemFull) == '+' then ["condition"] else [] + cond = ["condition" | jsymbol (itemBase itemFull) == '+'] return $! makeSentence $ ["the", name, stats] ++ cond ++ storeOwn ++ ["will now last longer"] setLastSlot :: MonadClientUI m => ActorId -> ItemId -> CStore -> m () setLastSlot aid iid cstore = do - mleader <- getsClient _sleader + mleader <- getsClient sleader when (Just aid == mleader) $ do ItemSlots itemSlots _ <- getsSession sslots case lookup iid $ map swap $ EM.assocs itemSlots of @@ -1138,14 +1171,13 @@ strike :: MonadClientUI m => Bool -> ActorId -> ActorId -> ItemId -> CStore -> m () strike catch source target iid cstore = assert (source /= target) $ do - actorAspect <- getsClient sactorAspect tb <- getsState $ getActorBody target tbUI <- getsSession $ getActorUI target sourceSeen <- getsState $ memActor source (blid tb) (ps, hurtMult) <- if sourceSeen then do - hurtMult <- getsState $ armorHurtBonus actorAspect source target - itemToF <- itemToFullClient + hurtMult <- getsState $ armorHurtBonus source target + itemToF <- getsState itemToFull sb <- getsState $ getActorBody source sbUI <- getsSession $ getActorUI source spart <- partActorLeader source sbUI @@ -1168,7 +1200,7 @@ else partItemShortAW side factionD cstore localTime msg | bhp tb <= 0 -- incapacitated, so doesn't actively block || hurtMult > 90 -- at most minor armor - || jdamage (itemBase itemFull) <= 0 = makeSentence $ + || jdamage (itemBase itemFull) == 0 = makeSentence $ [MU.SubjectVerbSg spart verb, tpart] ++ if bproj sb then [] diff --git a/Game/LambdaHack/Client/UI/DrawM.hs b/Game/LambdaHack/Client/UI/DrawM.hs --- a/Game/LambdaHack/Client/UI/DrawM.hs +++ b/Game/LambdaHack/Client/UI/DrawM.hs @@ -15,65 +15,63 @@ import Game.LambdaHack.Common.Prelude -import Control.Arrow (first) -import Control.Monad.ST.Strict +import Control.Monad.ST.Strict import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Ord +import Data.Ord import qualified Data.Text as T import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as VM -import Data.Word (Word16) -import GHC.Exts (inline) +import Data.Word (Word16) +import GHC.Exts (inline) import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Client.Bfs -import Game.LambdaHack.Client.BfsM -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI.ActorUI -import Game.LambdaHack.Client.UI.ItemDescription -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Client.Bfs +import Game.LambdaHack.Client.BfsM +import Game.LambdaHack.Client.CommonM +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI.ActorUI +import Game.LambdaHack.Client.UI.Frame +import Game.LambdaHack.Client.UI.ItemDescription +import Game.LambdaHack.Client.UI.MonadClientUI +import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemStrongest +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind import qualified Game.LambdaHack.Common.KindOps as KindOps -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ModeKind as MK -import Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace) +import Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace) import qualified Game.LambdaHack.Content.TileKind as TK targetDesc :: MonadClientUI m => Maybe Target -> m (Maybe Text, Maybe Text) targetDesc mtarget = do arena <- getArenaUI lidV <- viewedLevelUI - mleader <- getsClient _sleader + mleader <- getsClient sleader case mtarget of Just (TEnemy aid _) -> do side <- getsClient sside b <- getsState $ getActorBody aid bUI <- getsSession $ getActorUI aid - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` aid) - (EM.lookup aid actorAspect) - percentage = 100 * bhp b `div` xM (max 5 $ aMaxHP ar) + ar <- getsState $ getActorAspect aid + let percentage = 100 * bhp b `div` xM (max 5 $ aMaxHP ar) chs n = "[" <> T.replicate n "*" <> T.replicate (4 - n) "_" <> "]" stars = chs $ fromEnum $ max 0 $ min 4 $ percentage `div` 20 @@ -95,7 +93,7 @@ [] -> return $! "exact spot" <+> tshow p [(iid, kit@(k, _))] -> do localTime <- getsState $ getLocalTime lid - itemToF <- itemToFullClient + itemToF <- getsState itemToFull side <- getsClient sside factionD <- getsState sfactionD let (_, _, name, stats) = @@ -206,7 +204,7 @@ Level{lxsize, lysize, ltile=PointArray.Array{avector}} <- getLevel drawnLevelId totVisible <- totalVisible <$> getPerFid drawnLevelId - mleader <- getsClient _sleader + mleader <- getsClient sleader xhairPosRaw <- xhairToPos let xhairPos = fromMaybe originPoint xhairPosRaw s <- getState @@ -224,7 +222,7 @@ | pathGoal == xhairPos -> return tapPath _ -> getCachePath aid xhairPos) mleader let lpath = if null bline then [] - else maybe [] (\mp -> case mp of + else maybe [] (\case NoPath -> [] AndPath {pathList} -> pathList) mpath xhairHere = find (\(_, m) -> xhairPos == bpos m) @@ -271,7 +269,7 @@ SessionUI{sselected} <- getSession Level{lxsize, lactor} <- getLevel drawnLevelId side <- getsClient sside - mleader <- getsClient _sleader + mleader <- getsClient sleader s <- getState sactorUI <- getsSession sactorUI let {-# INLINE viewActor #-} @@ -316,7 +314,7 @@ totVisible <- totalVisible <$> getPerFid drawnLevelId mxhairPos <- xhairToPos mtgtPos <- do - mleader <- getsClient _sleader + mleader <- getsClient sleader case mleader of Nothing -> return Nothing Just leader -> do @@ -365,7 +363,7 @@ drawFrameStatus :: MonadClientUI m => LevelId -> m AttrLine drawFrameStatus drawnLevelId = do SessionUI{sselected, saimMode, swaitTimes, sitemSel} <- getSession - mleader <- getsClient _sleader + mleader <- getsClient sleader xhairPos <- xhairToPos tgtPos <- leaderTgtToPos mbfs <- maybe (return Nothing) (\aid -> Just <$> getCacheBfs aid) mleader @@ -443,7 +441,7 @@ Nothing -> return $! tgtBlurb Just kit@(k, _) -> do localTime <- getsState $ getLocalTime (blid b) - itemToF <- itemToFullClient + itemToF <- getsState itemToFull factionD <- getsState sfactionD let (_, _, name, stats) = partItem (bfid b) factionD @@ -465,9 +463,6 @@ <+:> targetStatus -- | Draw the whole screen: level map and status area. --- Pass at most a single page if overlay of text unchanged --- to the frontends to display separately or overlay over map, --- depending on the frontend. drawBaseFrame :: MonadClientUI m => ColorMode -> LevelId -> m FrameForall drawBaseFrame dm drawnLevelId = do Level{lxsize, lysize} <- getLevel drawnLevelId @@ -492,7 +487,7 @@ -- level descriptions (currently enforced max). drawArenaStatus :: Bool -> Level -> Int -> AttrLine drawArenaStatus explored - Level{ldepth=AbsDepth ld, ldesc, lseen, lexplorable} + Level{ldepth=AbsDepth ld, lname, lseen, lexplorable} width = let seenN = 100 * lseen `div` max 1 lexplorable seenTxt | explored || seenN >= 100 = "all" @@ -500,20 +495,18 @@ lvlN = T.justifyLeft 2 ' ' (tshow ld) seenStatus = "[" <> seenTxt <+> "seen]" in textToAL $ T.justifyLeft width ' ' - $ T.take 29 (lvlN <+> T.justifyLeft 26 ' ' ldesc) <+> seenStatus + $ T.take 29 (lvlN <+> T.justifyLeft 26 ' ' lname) <+> seenStatus drawLeaderStatus :: MonadClient m => Int -> m AttrLine drawLeaderStatus waitT = do let calmHeaderText = "Calm" hpHeaderText = "HP" - mleader <- getsClient _sleader + mleader <- getsClient sleader case mleader of Just leader -> do - actorAspect <- getsClient sactorAspect + ar <- getsState $ getActorAspect leader s <- getState - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) - showTrunc :: Show a => a -> String + let showTrunc :: Show a => a -> String showTrunc = (\t -> if length t > 3 then "***" else t) . show (darkL, bracedL, hpDelta, calmDelta, ahpS, bhpS, acalmS, bcalmS) = @@ -554,22 +547,22 @@ drawLeaderDamage :: MonadClientUI m => Int -> m AttrLine drawLeaderDamage width = do - mleader <- getsClient _sleader + mleader <- getsClient sleader let addColor = map (Color.attrChar2ToW32 Color.BrCyan) stats <- case mleader of Just leader -> do - allAssocsRaw <- fullAssocsClient leader [CEqp, COrgan] + allAssocsRaw <- getsState $ fullAssocs leader [CEqp, COrgan] let allAssocs = filter (isMelee . itemBase . snd) allAssocsRaw actorSk <- leaderSkillsClientUI - actorAspect <- getsClient sactorAspect - strongest <- pickWeaponM Nothing allAssocs actorSk actorAspect leader + actorAspect <- getsState sactorAspect + strongest <- pickWeaponM Nothing allAssocs actorSk leader let damage = case strongest of [] -> "0" (_, (_, itemFull)) : _ -> let tdice = show $ jdamage $ itemBase itemFull bonusRaw = aHurtMelee $ actorAspect EM.! leader bonus = min 200 $ max (-200) bonusRaw - unknownBonus = unknownMelee $ map snd allAssocs + unknownBonus = unknownMeleeBonus $ map snd allAssocs tbonus = if bonus == 0 then if unknownBonus then "+?" else "" else (if bonus > 0 then "+" else "") @@ -585,7 +578,7 @@ drawSelected :: MonadClientUI m => LevelId -> Int -> ES.EnumSet ActorId -> m (Int, AttrLine) drawSelected drawnLevelId width selected = do - mleader <- getsClient _sleader + mleader <- getsClient sleader side <- getsClient sside sactorUI <- getsSession sactorUI ours <- getsState $ filter (not . bproj . snd) diff --git a/Game/LambdaHack/Client/UI/EffectDescription.hs b/Game/LambdaHack/Client/UI/EffectDescription.hs --- a/Game/LambdaHack/Client/UI/EffectDescription.hs +++ b/Game/LambdaHack/Client/UI/EffectDescription.hs @@ -1,9 +1,12 @@ --- | Description of effects. No operation in this module --- involves state or monad types. +-- | Description of effects. module Game.LambdaHack.Client.UI.EffectDescription - ( effectToSuffix, featureToSuff, kindAspectToSuffix, affixDice - , featureToSentence, slotToSentence - , slotToName, slotToDesc, slotToDecorator, statSlots + ( effectToSuffix + , slotToSentence, slotToName, slotToDesc, slotToDecorator, statSlots + , kindAspectToSuffix, featureToSuff, featureToSentence, affixDice +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , tmodToSuff, affixBonus, wrapInParens, wrapInChevrons +#endif ) where import Prelude () @@ -13,12 +16,12 @@ import qualified Data.Text as T import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Common.Ability -import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.Ability +import Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Content.ItemKind +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.ItemKind -- | Suffix to append to a basic content name if the content causes the effect. -- @@ -36,7 +39,7 @@ ELabel _ -> "" -- printed specially EqpSlot{} -> "" -- used in @slotToSentence@ instead Burn d -> wrapInParens (tshow d - <+> if d > 1 then "burns" else "burn") + <+> if Dice.maxDice d > 1 then "burns" else "burn") Explode t -> "of" <+> tshow t <+> "explosion" RefillHP p | p > 0 -> "of healing" <+> wrapInParens (affixBonus p) RefillHP 0 -> error $ "" `showFailure` effect @@ -68,9 +71,10 @@ Nothing -> tshow dice <+> "moves" Just p -> makePhrase [MU.CarWs p "move"] in "of speed surge for" <+> moves - Teleport dice | dice <= 0 -> + Teleport dice | Dice.minDice dice <= 0 -> error $ "" `showFailure` effect - Teleport dice | dice <= 9 -> "of blinking" <+> wrapInParens (tshow dice) + Teleport dice | Dice.maxDice dice <= 9 -> + "of blinking" <+> wrapInParens (tshow dice) Teleport dice -> "of teleport" <+> wrapInParens (tshow dice) CreateItem COrgan grp tim -> let stime = if tim == TimerNone then "" else "for" <+> tshow tim <> ":" @@ -86,7 +90,7 @@ verb = if store == COrgan then "nullify" else "drop" in "of" <+> verb <+> ntxt <+> tshow grp -- TMI: <+> ppCStore store PolyItem -> "of repurpose on the ground" - Identify -> "of identify on the ground" + Identify -> "of identify" Detect radius -> "of detection" <+> wrapInParens (tshow radius) DetectActor radius -> "of actor detection" <+> wrapInParens (tshow radius) DetectItem radius -> "of item detection" <+> wrapInParens (tshow radius) @@ -107,6 +111,7 @@ Temporary _ -> "" Unique -> "" -- marked by capital letters in name Periodic -> "" -- printed specially + Composite effs -> T.intercalate " and then " $ map effectToSuffix effs slotToSentence :: EqpSlot -> Text slotToSentence es = case es of diff --git a/Game/LambdaHack/Client/UI/Frame.hs b/Game/LambdaHack/Client/UI/Frame.hs --- a/Game/LambdaHack/Client/UI/Frame.hs +++ b/Game/LambdaHack/Client/UI/Frame.hs @@ -1,21 +1,49 @@ +{-# LANGUAGE RankNTypes #-} -- | Screen frames. module Game.LambdaHack.Client.UI.Frame - ( SingleFrame(..), Frames + ( FrameST, FrameForall(..), writeLine + , SingleFrame(..), Frames , blankSingleFrame, overlayFrame, overlayFrameWithLines +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , truncateAttrLine +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Word (Word32) +import Control.Monad.ST.Strict +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as VM +import Data.Word -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Common.Color -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Client.UI.Overlay +import qualified Game.LambdaHack.Common.Color as Color +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray +type FrameST s = G.Mutable U.Vector s Word32 -> ST s () + +-- | Efficiently composable representation of an operation +-- on a frame, that is, on a mutable vector. When the composite operation +-- is eventually performed, the vector is frozen to become a 'SingleFrame'. +newtype FrameForall = FrameForall {unFrameForall :: forall s. FrameST s} + +-- | Representation of an operation of overwriting a frame with a single line +-- at the given row. +writeLine :: Int -> AttrLine -> FrameForall +{-# INLINE writeLine #-} +writeLine offset l = FrameForall $ \v -> do + let writeAt _ [] = return () + writeAt off (ac32 : rest) = do + VM.write v off (Color.attrCharW32 ac32) + writeAt (off + 1) rest + writeAt offset l + -- | An overlay that fits on the screen (or is meant to be truncated on display) -- and is padded to fill the whole screen -- and is displayed as a single game screen frame. @@ -23,7 +51,7 @@ -- Note that we don't provide a list of color-highlighed positions separately, -- because overlays need to obscure not only map, but the highlights as well. newtype SingleFrame = SingleFrame - {singleFrame :: PointArray.GArray Word32 AttrCharW32} + {singleFrame :: PointArray.GArray Word32 Color.AttrCharW32} deriving (Eq, Show) -- | Sequences of screen frames, including delays. @@ -33,11 +61,11 @@ blankSingleFrame = let lxsize = fst normalLevelBound + 1 lysize = snd normalLevelBound + 4 - in SingleFrame $ PointArray.replicateA lxsize lysize spaceAttrW32 + in SingleFrame $ PointArray.replicateA lxsize lysize Color.spaceAttrW32 -- | Truncate the overlay: for each line, if it's too long, it's truncated -- and if there are too many lines, excess is dropped and warning is appended. -truncateLines :: Bool -> [AttrLine] -> [AttrLine] +truncateLines :: Bool -> Overlay -> Overlay truncateLines onBlank l = let lxsize = fst normalLevelBound + 1 lysize = snd normalLevelBound + 1 @@ -57,24 +85,24 @@ truncateAttrLine w xs lenMax = case compare w (length xs) of LT -> let discarded = drop w xs - in if all (== spaceAttrW32) discarded + in if all (== Color.spaceAttrW32) discarded then take w xs - else take (w - 1) xs ++ [attrChar2ToW32 BrBlack '$'] + else take (w - 1) xs ++ [Color.attrChar2ToW32 Color.BrBlack '$'] EQ -> xs - GT -> let xsSpace = if null xs || last xs == spaceAttrW32 + GT -> let xsSpace = if null xs || last xs == Color.spaceAttrW32 then xs - else xs ++ [spaceAttrW32] + else xs ++ [Color.spaceAttrW32] whiteN = max (40 - length xsSpace) (1 + lenMax - length xsSpace) - in xsSpace ++ replicate whiteN spaceAttrW32 + in xsSpace ++ replicate whiteN Color.spaceAttrW32 -- | Overlays either the game map only or the whole empty screen frame. -- We assume the lines of the overlay are not too long nor too many. -overlayFrame :: Overlay -> FrameForall -> FrameForall +overlayFrame :: IntOverlay -> FrameForall -> FrameForall overlayFrame ov ff = FrameForall $ \v -> do unFrameForall ff v mapM_ (\(offset, l) -> unFrameForall (writeLine offset l) v) ov -overlayFrameWithLines :: Bool -> [AttrLine] -> FrameForall -> FrameForall +overlayFrameWithLines :: Bool -> Overlay -> FrameForall -> FrameForall overlayFrameWithLines onBlank l msf = let lxsize = fst normalLevelBound + 1 ov = map (\(y, al) -> (y * lxsize, al)) diff --git a/Game/LambdaHack/Client/UI/FrameM.hs b/Game/LambdaHack/Client/UI/FrameM.hs --- a/Game/LambdaHack/Client/UI/FrameM.hs +++ b/Game/LambdaHack/Client/UI/FrameM.hs @@ -1,6 +1,10 @@ -- | A set of Frame monad operations. module Game.LambdaHack.Client.UI.FrameM - ( drawOverlay, promptGetKey, stopPlayBack, animate, fadeOutOrIn + ( pushFrame, promptGetKey, stopPlayBack, animate, fadeOutOrIn +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , drawOverlay, renderFrames +#endif ) where import Prelude () @@ -9,38 +13,50 @@ import qualified Data.EnumMap.Strict as EM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI.Animation -import Game.LambdaHack.Client.UI.Config -import Game.LambdaHack.Client.UI.DrawM -import Game.LambdaHack.Client.UI.Frame +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI.Animation +import Game.LambdaHack.Client.UI.DrawM +import Game.LambdaHack.Client.UI.Frame import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.Msg -import Game.LambdaHack.Client.UI.MsgM -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.ClientOptions -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.State +import Game.LambdaHack.Client.UI.MonadClientUI +import Game.LambdaHack.Client.UI.Msg +import Game.LambdaHack.Client.UI.MsgM +import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Client.UI.UIOptions +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.State -- | Draw the current level with the overlay on top. -- If the overlay is too long, it's truncated. -- Similarly, for each line of the overlay, if it's too wide, it's truncated. drawOverlay :: MonadClientUI m - => ColorMode -> Bool -> [AttrLine] -> LevelId -> m FrameForall + => ColorMode -> Bool -> Overlay -> LevelId -> m FrameForall drawOverlay dm onBlank topTrunc lid = do mbaseFrame <- if onBlank then return $ FrameForall $ \_v -> return () else drawBaseFrame dm lid return $! overlayFrameWithLines onBlank topTrunc mbaseFrame +-- | Push the frame depicting the current level to the frame queue. +-- Only one line of the report is shown, as in animations, +-- because it may not be our turn, so we can't clear the message +-- to see what is underneath. +pushFrame :: MonadClientUI m => m () +pushFrame = do + lidV <- viewedLevelUI + report <- getReportUI + let truncRep = [renderReport report] + frame <- drawOverlay ColorFull False truncRep lidV + displayFrames lidV [Just frame] + promptGetKey :: MonadClientUI m - => ColorMode -> [AttrLine] -> Bool -> [K.KM] -> m K.KM + => ColorMode -> Overlay -> Bool -> [K.KM] -> m K.KM promptGetKey dm ov onBlank frontKeyKeys = do lidV <- viewedLevelUI keyPressed <- anyKeyPressed @@ -51,8 +67,8 @@ frontKeyFrame <- drawOverlay dm onBlank ov lidV displayFrames lidV [Just frontKeyFrame] modifySession $ \sess -> sess {slastPlay = kms} - Config{configRunStopMsgs} <- getsSession sconfig - when configRunStopMsgs $ promptAdd $ "Voicing '" <> tshow km <> "'." + UIOptions{uRunStopMsgs} <- getsSession sUIOptions + when uRunStopMsgs $ promptAdd $ "Voicing '" <> tshow km <> "'." return km _ : _ -> do -- We can't continue playback, so wipe out old slastPlay, srunning, etc. @@ -62,10 +78,14 @@ frontKeyFrame <- drawOverlay dm onBlank ov2 lidV connFrontendFrontKey frontKeyKeys frontKeyFrame [] -> do + -- If we ask for a key, then we don't want to run any more + -- and we want to avoid changing leader back to initial run leader + -- at the nearest @stopPlayBack@, etc. + modifySession $ \sess -> sess {srunning = Nothing} frontKeyFrame <- drawOverlay dm onBlank ov lidV connFrontendFrontKey frontKeyKeys frontKeyFrame - (seqCurrent, seqPrevious, k) <- getsSession slastRecord - let slastRecord = (km : seqCurrent, seqPrevious, k) + LastRecord seqCurrent seqPrevious k <- getsSession slastRecord + let slastRecord = LastRecord (km : seqCurrent) seqPrevious k modifySession $ \sess -> sess { slastRecord , sdisplayNeeded = False } return km @@ -74,7 +94,7 @@ stopPlayBack = do modifySession $ \sess -> sess { slastPlay = [] - , slastRecord = ([], [], 0) + , slastRecord = LastRecord [] [] 0 -- Needed to cancel macros that contain apostrophes. , swaitTimes = - abs (swaitTimes sess) } @@ -99,7 +119,7 @@ report <- getReportUI let truncRep = [renderReport report] basicFrame <- drawOverlay ColorFull False truncRep arena - snoAnim <- getsClient $ snoAnim . sdebugCli + snoAnim <- getsClient $ snoAnim . soptions return $! if fromMaybe False snoAnim then [Just basicFrame] else renderAnim basicFrame anim diff --git a/Game/LambdaHack/Client/UI/Frontend.hs b/Game/LambdaHack/Client/UI/Frontend.hs --- a/Game/LambdaHack/Client/UI/Frontend.hs +++ b/Game/LambdaHack/Client/UI/Frontend.hs @@ -2,15 +2,13 @@ -- | Display game data on the screen and receive user input -- using one of the available raw frontends and derived operations. module Game.LambdaHack.Client.UI.Frontend - ( -- * Connection types - FrontReq(..), ChanFrontend(..), KMP(..) + ( -- * Connection and initialization + FrontReq(..), ChanFrontend(..), chanFrontendIO -- * Re-exported part of the raw frontend , frontendName - -- * Derived operations - , chanFrontendIO #ifdef EXPOSE_INTERNAL -- * Internal operations - , FSession, getKey, fchanFrontend, display, defaultMaxFps, microInSec + , FrontSetup, getKey, fchanFrontend, display, defaultMaxFps, microInSec , frameTimeoutThread, lazyStartup, nullStartup, seqFrame #endif ) where @@ -19,29 +17,30 @@ import Game.LambdaHack.Common.Prelude -import Control.Concurrent -import Control.Concurrent.Async +import Control.Concurrent +import Control.Concurrent.Async import qualified Control.Concurrent.STM as STM -import Control.Monad.ST.Strict -import Data.IORef +import Control.Monad.ST.Strict +import Data.IORef import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as VM -import Data.Word +import Data.Word -import Game.LambdaHack.Client.UI.Frame +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client.UI.Frame import qualified Game.LambdaHack.Client.UI.Frontend.Chosen as Chosen -import Game.LambdaHack.Client.UI.Frontend.Common +import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Frontend.Teletype as Teletype +import Game.LambdaHack.Client.UI.Key (KMP (..)) import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray --- | The instructions sent by clients to the raw frontend. +-- | The instructions sent by clients to the raw frontend, indexed +-- by the returned value. data FrontReq :: * -> * where -- | Show a frame. FrontFrame :: {frontFrame :: FrameForall} -> FrontReq () @@ -52,30 +51,49 @@ , frontKeyFrame :: FrameForall } -> FrontReq KMP -- | Inspect the fkeyPressed MVar. FrontPressed :: FrontReq Bool - -- | discard a key in the queue, if any. + -- | Discard a key in the queue, if any. FrontDiscard :: FrontReq () -- | Add a key to the queue. FrontAdd :: KMP -> FrontReq () - -- | set in the frontend that it should auto-answer prompts. + -- | Set in the frontend that it should auto-answer prompts. FrontAutoYes :: Bool -> FrontReq () - -- | shut the frontend down. + -- | Shut the frontend down. FrontShutdown :: FrontReq () -- | Connection channel between a frontend and a client. Frontend acts -- as a server, serving keys, etc., when given frames to display. newtype ChanFrontend = ChanFrontend (forall a. FrontReq a -> IO a) -data FSession = FSession +-- | Machinery allocated for an individual frontend at its startup, +-- unchanged for its lifetime. +data FrontSetup = FrontSetup { fautoYesRef :: IORef Bool , fasyncTimeout :: Async () , fdelay :: MVar Int } --- | Display a prompt, wait for any of the specified keys (for any key, +-- | Initialize the frontend chosen by the player via client options. +chanFrontendIO :: ClientOptions -> IO ChanFrontend +chanFrontendIO soptions = do + let startup | sfrontendNull soptions = nullStartup + | sfrontendLazy soptions = lazyStartup + | sfrontendTeletype soptions = Teletype.startup soptions + | otherwise = Chosen.startup soptions + maxFps = fromMaybe defaultMaxFps $ smaxFps soptions + delta = max 1 $ microInSec `div` maxFps + rf <- startup + fautoYesRef <- newIORef $ not $ sdisableAutoYes soptions + fdelay <- newMVar 0 + fasyncTimeout <- async $ frameTimeoutThread delta fdelay rf + -- Warning: not linking @fasyncTimeout@, so it'd better not crash. + let fs = FrontSetup{..} + return $ fchanFrontend soptions fs rf + +-- Display a frame, wait for any of the specified keys (for any key, -- if the list is empty). Repeat if an unexpected key received. -getKey :: DebugModeCli -> FSession -> RawFrontend -> [K.KM] -> FrameForall +getKey :: ClientOptions -> FrontSetup -> RawFrontend -> [K.KM] -> FrameForall -> IO KMP -getKey sdebugCli fs rf@RawFrontend{fchanKey} keys frame = do +getKey soptions fs rf@RawFrontend{fchanKey} keys frame = do autoYes <- readIORef $ fautoYesRef fs if autoYes && (null keys || K.spaceKM `elem` keys) then do display rf frame @@ -86,15 +104,15 @@ kmp <- STM.atomically $ STM.readTQueue fchanKey if null keys || kmpKeyMod kmp `elem` keys then return kmp - else getKey sdebugCli fs rf keys frame + else getKey soptions fs rf keys frame --- | Read UI requests from the client and send them to the frontend, -fchanFrontend :: DebugModeCli -> FSession -> RawFrontend -> ChanFrontend -fchanFrontend sdebugCli fs@FSession{..} rf = - ChanFrontend $ \req -> case req of +-- Read UI requests from the client and send them to the frontend, +fchanFrontend :: ClientOptions -> FrontSetup -> RawFrontend -> ChanFrontend +fchanFrontend soptions fs@FrontSetup{..} rf = + ChanFrontend $ \case FrontFrame{..} -> display rf frontFrame FrontDelay k -> modifyMVar_ fdelay $ return . (+ k) - FrontKey{..} -> getKey sdebugCli fs rf frontKeyKeys frontKeyFrame + FrontKey{..} -> getKey soptions fs rf frontKeyKeys frontKeyFrame FrontPressed -> do noKeysPending <- STM.atomically $ STM.isEmptyTQueue (fchanKey rf) return $! not noKeysPending @@ -174,19 +192,3 @@ `seq` Color.charFromW32 attr == ' ' `seq` () in return $! PointArray.foldlA' seqAttr () singleFrame - -chanFrontendIO :: DebugModeCli -> IO ChanFrontend -chanFrontendIO sdebugCli = do - let startup | sfrontendNull sdebugCli = nullStartup - | sfrontendLazy sdebugCli = lazyStartup - | sfrontendTeletype sdebugCli = Teletype.startup sdebugCli - | otherwise = Chosen.startup sdebugCli - maxFps = fromMaybe defaultMaxFps $ smaxFps sdebugCli - delta = max 1 $ microInSec `div` maxFps - rf <- startup - fautoYesRef <- newIORef $ not $ sdisableAutoYes sdebugCli - fdelay <- newMVar 0 - fasyncTimeout <- async $ frameTimeoutThread delta fdelay rf - -- Warning: not linking @fasyncTimeout@, so it'd better not crash. - let fs = FSession{..} - return $ fchanFrontend sdebugCli fs rf diff --git a/Game/LambdaHack/Client/UI/Frontend/Chosen.hs b/Game/LambdaHack/Client/UI/Frontend/Chosen.hs --- a/Game/LambdaHack/Client/UI/Frontend/Chosen.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Chosen.hs @@ -17,5 +17,5 @@ #elif USE_BROWSER import Game.LambdaHack.Client.UI.Frontend.Dom #else -import Game.LambdaHack.Client.UI.Frontend.Gtk +import Game.LambdaHack.Client.UI.Frontend.Sdl #endif diff --git a/Game/LambdaHack/Client/UI/Frontend/Common.hs b/Game/LambdaHack/Client/UI/Frontend/Common.hs --- a/Game/LambdaHack/Client/UI/Frontend/Common.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Common.hs @@ -1,6 +1,6 @@ -- | Screen frames and animations. module Game.LambdaHack.Client.UI.Frontend.Common - ( RawFrontend(..), KMP(..) + ( RawFrontend(..) , startupBound, createRawFrontend, resetChanKey, saveKMP , modifierTranslate ) where @@ -9,17 +9,17 @@ import Game.LambdaHack.Common.Prelude -import Control.Concurrent -import Control.Concurrent.Async +import Control.Concurrent +import Control.Concurrent.Async import qualified Control.Concurrent.STM as STM -import Game.LambdaHack.Client.UI.Frame +import Game.LambdaHack.Client.UI.Frame +import Game.LambdaHack.Client.UI.Key (KMP (..)) import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Common.Point - -data KMP = KMP { kmpKeyMod :: K.KM - , kmpPointer :: Point } +import Game.LambdaHack.Common.Point +-- | Raw frontend definition. The minimal closed set of values that need +-- to depend on the specifics of the chosen frontend. data RawFrontend = RawFrontend { fdisplay :: SingleFrame -> IO () , fshutdown :: IO () diff --git a/Game/LambdaHack/Client/UI/Frontend/Curses.hs b/Game/LambdaHack/Client/UI/Frontend/Curses.hs --- a/Game/LambdaHack/Client/UI/Frontend/Curses.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Curses.hs @@ -9,19 +9,19 @@ import Game.LambdaHack.Common.Prelude -import Control.Concurrent.Async -import Data.Char (chr, ord) +import Control.Concurrent.Async +import Data.Char (chr, ord) import qualified Data.Map.Strict as M import qualified UI.HSCurses.Curses as C import qualified UI.HSCurses.CursesHelper as C -import Game.LambdaHack.Client.UI.Frame -import Game.LambdaHack.Client.UI.Frontend.Common +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client.UI.Frame +import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -- | Session data maintained by the frontend. @@ -36,8 +36,8 @@ frontendName = "curses" -- | Starts the main program loop using the frontend input and output. -startup :: DebugModeCli -> IO RawFrontend -startup _sdebugCli = do +startup :: ClientOptions -> IO RawFrontend +startup _soptions = do C.start void $ C.cursSet C.CursorInvisible let s = [ ((fg, bg), C.Style (toFColor fg) (toBColor bg)) @@ -46,7 +46,7 @@ , bg <- [Color.Black, Color.Blue, Color.White, Color.BrBlack] ] nr <- C.colorPairs when (nr < length s) $ - C.end >> (error $ "terminal has too few color pairs" `showFailure` nr) + C.end >> error ("terminal has too few color pairs" `showFailure` nr) let (ks, vs) = unzip s ws <- C.convertStyles vs let swin = C.stdScr diff --git a/Game/LambdaHack/Client/UI/Frontend/Dom.hs b/Game/LambdaHack/Client/UI/Frontend/Dom.hs --- a/Game/LambdaHack/Client/UI/Frontend/Dom.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Dom.hs @@ -1,4 +1,4 @@ --- | Text frontend running in Browser. +-- | Text frontend running in a browser. module Game.LambdaHack.Client.UI.Frontend.Dom ( startup, frontendName ) where @@ -7,14 +7,14 @@ import Game.LambdaHack.Common.Prelude -import Control.Concurrent +import Control.Concurrent import qualified Control.Monad.IO.Class as IO -import Control.Monad.Trans.Reader (ask) +import Control.Monad.Trans.Reader (ask) import qualified Data.Char as Char -import Data.IORef +import Data.IORef import qualified Data.Vector as V import qualified Data.Vector.Unboxed as U -import Data.Word (Word32) +import Data.Word (Word32) import GHCJS.DOM (currentDocument, currentWindow) import GHCJS.DOM.CSSStyleDeclaration (setProperty) @@ -22,7 +22,7 @@ import GHCJS.DOM.Element (Element (Element), setInnerHTML) import GHCJS.DOM.ElementCSSInlineStyle (getStyle) import GHCJS.DOM.EventM (EventM, mouseAltKey, mouseButton, mouseCtrlKey, - mouseMetaKey, mouseShiftKey, on, on, preventDefault, + mouseMetaKey, mouseShiftKey, on, preventDefault, stopPropagation) import GHCJS.DOM.GlobalEventHandlers (contextMenu, keyDown, mouseUp, wheel) import GHCJS.DOM.HTMLCollection (itemUnsafe) @@ -42,13 +42,13 @@ import GHCJS.DOM.WheelEvent (getDeltaY) import GHCJS.DOM.Window (requestAnimationFrame_) -import Game.LambdaHack.Client.UI.Frame -import Game.LambdaHack.Client.UI.Frontend.Common +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client.UI.Frame +import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -- | Session data maintained by the frontend. @@ -66,14 +66,14 @@ frontendName = "browser" -- | Starts the main program loop using the frontend input and output. -startup :: DebugModeCli -> IO RawFrontend -startup sdebugCli = do +startup :: ClientOptions -> IO RawFrontend +startup soptions = do rfMVar <- newEmptyMVar - flip runDOM undefined $ runWeb sdebugCli rfMVar + flip runDOM undefined $ runWeb soptions rfMVar takeMVar rfMVar -runWeb :: DebugModeCli -> MVar RawFrontend -> DOM () -runWeb sdebugCli@DebugModeCli{..} rfMVar = do +runWeb :: ClientOptions -> MVar RawFrontend -> DOM () +runWeb soptions@ClientOptions{..} rfMVar = do -- Init the document. Just doc <- currentDocument Just scurrentWindow <- currentWindow @@ -114,7 +114,7 @@ scharCells <- flattenTable tableElem spreviousFrame <- newIORef blankSingleFrame let sess = FrontendSession{..} - rf <- IO.liftIO $ createRawFrontend (display sdebugCli sess) shutdown + rf <- IO.liftIO $ createRawFrontend (display soptions sess) shutdown let readMod = do modCtrl <- ask >>= getCtrlKey modShift <- ask >>= getShiftKey @@ -238,11 +238,11 @@ return $! V.fromListN (lxsize * lysize) $ concat lrc -- | Output to the screen via the frontend. -display :: DebugModeCli +display :: ClientOptions -> FrontendSession -- ^ frontend session data -> SingleFrame -- ^ the screen frame to draw -> IO () -display DebugModeCli{scolorIsBold} +display ClientOptions{scolorIsBold} FrontendSession{..} !curFrame = flip runDOM undefined $ do let setChar :: Int -> Word32 -> Word32 -> DOM () diff --git a/Game/LambdaHack/Client/UI/Frontend/Gtk.hs b/Game/LambdaHack/Client/UI/Frontend/Gtk.hs --- a/Game/LambdaHack/Client/UI/Frontend/Gtk.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Gtk.hs @@ -2,32 +2,28 @@ -- | Text frontend based on Gtk. module Game.LambdaHack.Client.UI.Frontend.Gtk ( startup, frontendName -#ifdef EXPOSE_INTERNAL - -- * Internal operations - , startupFun, shutdown, doAttr, extraAttr, display -#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude hiding (Alt) -import Control.Concurrent +import Control.Concurrent import qualified Control.Monad.IO.Class as IO import qualified Data.IntMap.Strict as IM -import Data.IORef +import Data.IORef import qualified Data.Text as T import qualified Game.LambdaHack.Common.PointArray as PointArray -import Graphics.UI.Gtk hiding (Point) -import System.Exit (exitFailure) +import Graphics.UI.Gtk hiding (Point) +import System.Exit (exitFailure) -import Game.LambdaHack.Client.UI.Frame -import Game.LambdaHack.Client.UI.Frontend.Common +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client.UI.Frame +import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point -- | Session data maintained by the frontend. data FrontendSession = FrontendSession @@ -43,11 +39,11 @@ -- -- Because of Windows, GTK needs to be on a bound thread, -- so we can't avoid the communication overhead of bound threads. -startup :: DebugModeCli -> IO RawFrontend -startup sdebugCli = startupBound $ startupFun sdebugCli +startup :: ClientOptions -> IO RawFrontend +startup soptions = startupBound $ startupFun soptions -startupFun :: DebugModeCli -> MVar RawFrontend -> IO () -startupFun sdebugCli@DebugModeCli{..} rfMVar = do +startupFun :: ClientOptions -> MVar RawFrontend -> IO () +startupFun soptions@ClientOptions{..} rfMVar = do -- Init GUI. unsafeInitGUIForThreadedRTS -- Text attributes. @@ -75,7 +71,7 @@ mapM (\ak -> do tt <- textTagNew Nothing textTagTableAdd ttt tt - doAttr sdebugCli tt (emulateBox ak) + doAttr soptions tt (emulateBox ak) return (fromEnum ak, tt)) [ Color.Attr{fg, bg} | fg <- [minBound..maxBound], bg <- [minBound..maxBound] ] @@ -203,21 +199,21 @@ shutdown :: IO () shutdown = postGUISync mainQuit -doAttr :: DebugModeCli -> TextTag -> (Color.Color, Color.Color) -> IO () -doAttr sdebugCli tt (fg, bg) +doAttr :: ClientOptions -> TextTag -> (Color.Color, Color.Color) -> IO () +doAttr soptions tt (fg, bg) | fg == Color.defFG && bg == Color.Black = return () | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg] | bg == Color.Black = - set tt $ extraAttr sdebugCli + set tt $ extraAttr soptions ++ [textTagForeground := Color.colorToRGB fg] | otherwise = - set tt $ extraAttr sdebugCli + set tt $ extraAttr soptions ++ [ textTagForeground := Color.colorToRGB fg , textTagBackground := Color.colorToRGB bg ] -extraAttr :: DebugModeCli -> [AttrOp TextTag] -extraAttr DebugModeCli{scolorIsBold} = +extraAttr :: ClientOptions -> [AttrOp TextTag] +extraAttr ClientOptions{scolorIsBold} = [textTagWeight := fromEnum WeightBold | scolorIsBold == Just True] -- , textTagStretch := StretchUltraExpanded diff --git a/Game/LambdaHack/Client/UI/Frontend/Sdl.hs b/Game/LambdaHack/Client/UI/Frontend/Sdl.hs --- a/Game/LambdaHack/Client/UI/Frontend/Sdl.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Sdl.hs @@ -3,7 +3,8 @@ ( startup, frontendName #ifdef EXPOSE_INTERNAL -- * Internal operations - , startupFun, shutdown, display + , FontAtlas, FrontendSession(..), startupFun, shutdown, forceShutdown + , display, displayNoLock, modTranslate, keyTranslate, colorToRGBA #endif ) where @@ -11,31 +12,31 @@ import Game.LambdaHack.Common.Prelude hiding (Alt) -import Control.Concurrent -import Control.Concurrent.Async +import Control.Concurrent +import Control.Concurrent.Async import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM -import Data.IORef +import Data.IORef import qualified Data.Text as T import qualified Data.Vector.Unboxed as U -import Data.Word (Word32, Word8) -import Foreign.C.Types (CInt) -import System.Directory -import System.Exit (exitSuccess) -import System.FilePath +import Data.Word (Word32, Word8) +import Foreign.C.Types (CInt) +import System.Directory +import System.Exit (exitSuccess) +import System.FilePath import qualified SDL import qualified SDL.Font as TTF -import SDL.Input.Keyboard.Codes +import SDL.Input.Keyboard.Codes import qualified SDL.Vect as Vect -import Game.LambdaHack.Client.UI.Frame -import Game.LambdaHack.Client.UI.Frontend.Common +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client.UI.Frame +import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray type FontAtlas = EM.EnumMap Color.AttrCharW32 SDL.Texture @@ -61,11 +62,11 @@ -- Apparently some SDL backends are not thread-safe -- (https://wiki.libsdl.org/FAQDevelopment), -- so we stick to main thread. -startup :: DebugModeCli -> IO RawFrontend -startup sdebugCli = startupBound $ startupFun sdebugCli +startup :: ClientOptions -> IO RawFrontend +startup soptions = startupBound $ startupFun soptions -startupFun :: DebugModeCli -> MVar RawFrontend -> IO () -startupFun sdebugCli@DebugModeCli{..} rfMVar = do +startupFun :: ClientOptions -> MVar RawFrontend -> IO () +startupFun soptions@ClientOptions{..} rfMVar = do SDL.initialize [SDL.InitVideo, SDL.InitEvents] let title = fromJust stitle fontFileName = T.unpack (fromJust sdlFontFile) @@ -105,7 +106,7 @@ sforcedShutdown <- newIORef False sdisplayPermitted <- newMVar True let sess = FrontendSession{..} - rf <- createRawFrontend (display sdebugCli sess) (shutdown sess) + rf <- createRawFrontend (display soptions sess) (shutdown sess) putMVar rfMVar rf let pointTranslate :: forall i. (Enum i) => Vect.Point Vect.V2 i -> Point pointTranslate (SDL.P (SDL.V2 x y)) = @@ -123,7 +124,7 @@ writeIORef stexture newTexture prevFrame <- readIORef spreviousFrame writeIORef spreviousFrame blankSingleFrame - displayNoLock sdebugCli sess prevFrame + displayNoLock soptions sess prevFrame putMVar sdisplayPermitted displayPermitted storeKeys :: IO () storeKeys = do @@ -195,15 +196,15 @@ shutdown sess -- | Add a frame to be drawn. -display :: DebugModeCli +display :: ClientOptions -> FrontendSession -- ^ frontend session data -> SingleFrame -- ^ the screen frame to draw -> IO () -display sdebugCli sess@FrontendSession{..} curFrame = do +display soptions sess@FrontendSession{..} curFrame = do displayPermitted <- takeMVar sdisplayPermitted if displayPermitted then do -- Apparently some SDL backends are not thread-safe, so keep to main thread: - a <- asyncBound $ displayNoLock sdebugCli sess curFrame + a <- asyncBound $ displayNoLock soptions sess curFrame wait a putMVar sdisplayPermitted displayPermitted else do @@ -217,11 +218,11 @@ -- to avoid exiting via "thread blocked". threadDelay 50000 -displayNoLock :: DebugModeCli +displayNoLock :: ClientOptions -> FrontendSession -- ^ frontend session data -> SingleFrame -- ^ the screen frame to draw -> IO () -displayNoLock DebugModeCli{..} FrontendSession{..} curFrame = do +displayNoLock ClientOptions{..} FrontendSession{..} curFrame = do let isFonFile = "fon" `isSuffixOf` T.unpack (fromJust sdlFontFile) sdlSizeAdd = fromJust $ if isFonFile then sdlFonSizeAdd else sdlTtfSizeAdd boxSize <- (+ sdlSizeAdd) <$> TTF.height sfont diff --git a/Game/LambdaHack/Client/UI/Frontend/Teletype.hs b/Game/LambdaHack/Client/UI/Frontend/Teletype.hs --- a/Game/LambdaHack/Client/UI/Frontend/Teletype.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Teletype.hs @@ -1,29 +1,25 @@ --- | Line terimanl text frontend based on stdin/stdout, intended for logging --- tests, but may be used for a teletype terminal, or keyboard and printer. +-- | Line terminal text frontend based on stdin/stdout, intended for logging +-- tests, but may be used on a teletype terminal, or with keyboard and printer. module Game.LambdaHack.Client.UI.Frontend.Teletype ( startup, frontendName -#ifdef EXPOSE_INTERNAL - -- * Internal operations - , shutdown, display -#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Control.Concurrent.Async -import Data.Char (chr, ord) +import Control.Concurrent.Async +import Data.Char (chr, ord) import qualified Data.Char as Char import qualified System.IO as SIO -import Game.LambdaHack.Client.UI.Frame -import Game.LambdaHack.Client.UI.Frontend.Common +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client.UI.Frame +import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -- No session data maintained by this frontend @@ -33,8 +29,8 @@ frontendName = "teletype" -- | Set up the frontend input and output. -startup :: DebugModeCli -> IO RawFrontend -startup _sdebugCli = do +startup :: ClientOptions -> IO RawFrontend +startup _soptions = do rf <- createRawFrontend display shutdown let storeKeys :: IO () storeKeys = do diff --git a/Game/LambdaHack/Client/UI/Frontend/Vty.hs b/Game/LambdaHack/Client/UI/Frontend/Vty.hs --- a/Game/LambdaHack/Client/UI/Frontend/Vty.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Vty.hs @@ -14,7 +14,7 @@ import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.Frontend.Common import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Common.ClientOptions +import Game.LambdaHack.Client.ClientOptions import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point @@ -30,8 +30,8 @@ frontendName = "vty" -- | Starts the main program loop using the frontend input and output. -startup :: DebugModeCli -> IO RawFrontend -startup _sdebugCli = do +startup :: ClientOptions -> IO RawFrontend +startup _soptions = do svty <- mkVty mempty let sess = FrontendSession{..} rf <- createRawFrontend (display sess) (Vty.shutdown svty) diff --git a/Game/LambdaHack/Client/UI/HandleHelperM.hs b/Game/LambdaHack/Client/UI/HandleHelperM.hs --- a/Game/LambdaHack/Client/UI/HandleHelperM.hs +++ b/Game/LambdaHack/Client/UI/HandleHelperM.hs @@ -1,10 +1,10 @@ -- | Helper functions for both inventory management and human commands. module Game.LambdaHack.Client.UI.HandleHelperM - ( MError, FailOrCmd, FailError - , showFailError, mergeMError, failWith, failSer, failMsg, weaveJust + ( FailError, showFailError, MError, mergeMError, FailOrCmd, failWith + , failSer, failMsg, weaveJust , sortSlots, memberCycle, memberBack, partyAfterLeader , pickLeader, pickLeaderWithPointer - , itemOverlay, statsOverlay, pickNumber + , itemOverlay, statsOverlay, pickNumber, lookAt ) where import Prelude () @@ -14,39 +14,40 @@ import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Function -import Data.Ord +import Data.Function +import Data.Ord import qualified Data.Text as T import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI.ActorUI -import Game.LambdaHack.Client.UI.EffectDescription -import Game.LambdaHack.Client.UI.ItemDescription -import Game.LambdaHack.Client.UI.ItemSlot +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI.ActorUI +import Game.LambdaHack.Client.UI.EffectDescription +import Game.LambdaHack.Client.UI.ItemDescription +import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.MsgM -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.OverlayM -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Client.UI.Slideshow -import Game.LambdaHack.Client.UI.SlideshowM -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemStrongest -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State +import Game.LambdaHack.Client.UI.MonadClientUI +import Game.LambdaHack.Client.UI.MsgM +import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Client.UI.Slideshow +import Game.LambdaHack.Client.UI.SlideshowM +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.ItemStrongest +import qualified Game.LambdaHack.Common.Kind as Kind +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Content.ItemKind as IK +import qualified Game.LambdaHack.Content.TileKind as TK +-- | Message describing the cause of failure of human command. newtype FailError = FailError {failError :: Text} deriving Show @@ -79,7 +80,7 @@ sortSlots :: MonadClientUI m => FactionId -> Maybe Actor -> m () sortSlots fid mbody = do - itemToF <- itemToFullClient + itemToF <- getsState itemToFull s <- getState let -- If apperance the same, keep the order from before sort. apperance ItemFull{itemBase} = @@ -234,11 +235,10 @@ Nothing -> failMsg "not pointing at an actor" Just (aid, b, _) -> pick (aid, b) --- | Create a list of item names. itemOverlay :: MonadClientUI m => CStore -> LevelId -> ItemBag -> m OKX itemOverlay store lid bag = do localTime <- getsState $ getLocalTime lid - itemToF <- itemToFullClient + itemToF <- getsState itemToFull ItemSlots itemSlots organSlots <- getsSession sslots side <- getsClient sside factionD <- getsState sfactionD @@ -272,9 +272,8 @@ statsOverlay :: MonadClient m => ActorId -> m OKX statsOverlay aid = do b <- getsState $ getActorBody aid - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect) - prSlot :: (Y, SlotChar) -> IK.EqpSlot -> (Text, KYX) + ar <- getsState $ getActorAspect aid + let prSlot :: (Y, SlotChar) -> IK.EqpSlot -> (Text, KYX) prSlot (y, c) eqpSlot = let statName = slotToName eqpSlot fullText t = @@ -323,3 +322,45 @@ case res of Right k | k <= 0 -> error $ "" `showFailure` (res, kAll) _ -> return res + +-- | Produces a textual description of the terrain and items at an already +-- explored position. Mute for unknown positions. +-- The detailed variant is for use in the aiming mode. +lookAt :: MonadClientUI m + => Bool -- ^ detailed? + -> Text -- ^ how to start tile description + -> Bool -- ^ can be seen right now? + -> Point -- ^ position to describe + -> ActorId -- ^ the actor that looks + -> Text -- ^ an extra sentence to print + -> m Text +lookAt detailed tilePrefix canSee pos aid msg = do + Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops + itemToF <- getsState itemToFull + b <- getsState $ getActorBody aid + -- Not using @viewedLevelUI@, because @aid@ may be temporarily not a leader. + saimMode <- getsSession saimMode + let lidV = maybe (blid b) aimLevelId saimMode + lvl <- getLevel lidV + localTime <- getsState $ getLocalTime lidV + subject <- partAidLeader aid + is <- getsState $ getFloorBag lidV pos + side <- getsClient sside + factionD <- getsState sfactionD + let verb = MU.Text $ if | pos == bpos b && lidV == blid b -> "stand on" + | canSee -> "notice" + | otherwise -> "remember" + let nWs (iid, kit@(k, _)) = + partItemWs side factionD k CGround localTime (itemToF iid kit) + isd = if EM.size is == 0 then "" + else makeSentence [ MU.SubjectVerbSg subject verb + , MU.WWandW $ map nWs $ EM.assocs is] + tile = lvl `at` pos + tileText = TK.tname (okind tile) + tilePart | T.null tilePrefix = MU.Text tileText + | otherwise = MU.AW $ MU.Text tileText + tileDesc = [MU.Text tilePrefix, tilePart] + if | detailed -> + return $! makeSentence tileDesc <+> msg <+> isd + | otherwise -> + return $! msg <+> isd diff --git a/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs b/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs --- a/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs +++ b/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs @@ -1,9 +1,10 @@ {-# LANGUAGE DataKinds, GADTs #-} --- | Semantics of 'Command.Cmd' client commands that return server commands. +-- | Semantics of "Game.LambdaHack.Client.UI.HumanCmd" +-- client commands that return server requests. -- A couple of them do not take time, the rest does. --- Here prompts and menus and displayed, but any feedback resulting +-- Here prompts and menus are displayed, but any feedback resulting -- from the commands (e.g., from inventory manipulation) is generated later on, --- for all clients that witness the results of the commands. +-- by the server, for all clients that witness the results of the commands. module Game.LambdaHack.Client.UI.HandleHumanGlobalM ( -- * Meta commands byAreaHuman, byAimModeHuman, byItemModeHuman @@ -17,10 +18,17 @@ , alterDirHuman, alterWithPointerHuman , helpHuman, itemMenuHuman, chooseItemMenuHuman , mainMenuHuman, settingsMenuHuman, challengesMenuHuman - , gameDifficultyIncr, gameWolfToggle, gameFishToggle, gameScenarioIncr + , gameScenarioIncr, gameDifficultyIncr, gameWolfToggle, gameFishToggle -- * Global commands that never take time , gameRestartHuman, gameExitHuman, gameSaveHuman , tacticHuman, automateHuman +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , areaToRectangles, meleeAid, displaceAid, moveSearchAlter, goToXhair + , multiActorGoTo, selectItemsToMove, moveItems, projectItem, applyItem + , alterTile, alterTileAtPos, verifyAlters, verifyEscape, guessAlter + , artWithVersion, generateMenu, nxtGameMode +#endif ) where import Prelude () @@ -34,51 +42,53 @@ import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M import qualified Data.Text as T -import Data.Version +import Data.Version import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Client.Bfs -import Game.LambdaHack.Client.BfsM -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI.ActorUI -import Game.LambdaHack.Client.UI.Config -import Game.LambdaHack.Client.UI.FrameM -import Game.LambdaHack.Client.UI.Frontend (frontendName) -import Game.LambdaHack.Client.UI.HandleHelperM -import Game.LambdaHack.Client.UI.HandleHumanLocalM -import Game.LambdaHack.Client.UI.HumanCmd (CmdArea (..), Trigger (..)) +import Game.LambdaHack.Client.Bfs +import Game.LambdaHack.Client.BfsM +import Game.LambdaHack.Client.CommonM +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.Request +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI.ActorUI +import Game.LambdaHack.Client.UI.FrameM +import Game.LambdaHack.Client.UI.Frontend (frontendName) +import Game.LambdaHack.Client.UI.HandleHelperM +import Game.LambdaHack.Client.UI.HandleHumanLocalM +import Game.LambdaHack.Client.UI.HumanCmd (CmdArea (..), Trigger (..)) import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd -import Game.LambdaHack.Client.UI.InventoryM +import Game.LambdaHack.Client.UI.InventoryM +import Game.LambdaHack.Client.UI.ItemDescription import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.KeyBindings -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.Msg -import Game.LambdaHack.Client.UI.MsgM -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.RunM -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Client.UI.Slideshow -import Game.LambdaHack.Client.UI.SlideshowM -import Game.LambdaHack.Common.Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Client.UI.KeyBindings +import Game.LambdaHack.Client.UI.MonadClientUI +import Game.LambdaHack.Client.UI.Msg +import Game.LambdaHack.Client.UI.MsgM +import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.RunM +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Client.UI.Slideshow +import Game.LambdaHack.Client.UI.SlideshowM +import Game.LambdaHack.Client.UI.UIOptions +import Game.LambdaHack.Common.Ability +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Content.TileKind (TileKind) +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.RuleKind +import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK -- * ByArea @@ -400,14 +410,15 @@ tpos = spos `shift` dir -- target position t = lvl `at` tpos alterMinSkill = Tile.alterMinSkill coTileSpeedup t + bag <- getsState $ getEmbedBag (blid sb) tpos runStopOrCmd <- -- Movement requires full access. if | Tile.isWalkable coTileSpeedup t -> -- A potential invisible actor is hit. War started without asking. return $ Right $ RequestAnyAbility $ ReqMove dir -- No access, so search and/or alter the tile. - | Tile.isSuspect coTileSpeedup t -- not yet searched - || Tile.isHideAs coTileSpeedup t -- search again, could be swapped + | not (null bag) + || Tile.isSuspect coTileSpeedup t -- not yet searched || alterMinSkill < 10 || alterMinSkill >= 10 && alterSkill >= alterMinSkill -> if | alterSkill < alterMinSkill -> failSer AlterUnwalked @@ -441,7 +452,7 @@ side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD leader <- getLeaderUI - Config{configRunStopMsgs} <- getsSession sconfig + UIOptions{uRunStopMsgs} <- getsSession sUIOptions keyPressed <- anyKeyPressed srunning <- getsSession srunning -- When running, stop if disturbed. If not running, stop at once. @@ -452,13 +463,13 @@ Just RunParams{runMembers} | noRunWithMulti fact && runMembers /= [leader] -> do stopPlayBack - if configRunStopMsgs + if uRunStopMsgs then weaveJust <$> failWith "run stop: automatic leader change" else return $ Left Nothing Just _runParams | keyPressed -> do discardPressedKey stopPlayBack - if configRunStopMsgs + if uRunStopMsgs then weaveJust <$> failWith "run stop: key pressed" else weaveJust <$> failWith "interrupted" Just runParams -> do @@ -467,7 +478,7 @@ case runOutcome of Left stopMsg -> do stopPlayBack - if configRunStopMsgs + if uRunStopMsgs then weaveJust <$> failWith ("run stop:" <+> stopMsg) else return $ Left Nothing Right runCmd -> @@ -478,8 +489,7 @@ moveOnceToXhairHuman :: MonadClientUI m => m (FailOrCmd RequestAnyAbility) moveOnceToXhairHuman = goToXhair True False -goToXhair :: MonadClientUI m - => Bool -> Bool -> m (FailOrCmd RequestAnyAbility) +goToXhair :: MonadClientUI m => Bool -> Bool -> m (FailOrCmd RequestAnyAbility) goToXhair initialStep run = do aimMode <- getsSession saimMode -- Movement is legal only outside aiming mode. @@ -593,7 +603,7 @@ Nothing -> -- the case of old selection or selection from another actor moveItemHuman cLegalRaw destCStore mverb auto Just (k, it) -> assert (k > 0) $ do - itemToF <- itemToFullClient + itemToF <- getsState itemToFull let eqpFree = eqpFreeN b kToPick | destCStore == CEqp = min eqpFree k | otherwise = k @@ -632,11 +642,9 @@ -- The calmE is inaccurate also if an item not IDed, but that's intended -- and the server will ignore and warn (and content may avoid that, -- e.g., making all rings identified) - actorAspect <- getsClient sactorAspect + ar <- getsState $ getActorAspect leader lastItemMove <- getsSession slastItemMove - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) - calmE = calmEnough b ar + let calmE = calmEnough b ar cLegalE | calmE = cLegalRaw | destCStore == CSha = [] | otherwise = delete CSha cLegalRaw @@ -674,13 +682,10 @@ moveItems cLegalRaw (fromCStore, l) destCStore = do leader <- getLeaderUI b <- getsState $ getActorBody leader - actorAspect <- getsClient sactorAspect + ar <- getsState $ getActorAspect leader discoBenefit <- getsClient sdiscoBenefit - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) - calmE = calmEnough b ar - ret4 :: MonadClientUI m - => [(ItemId, ItemFull)] + let calmE = calmEnough b ar + ret4 :: [(ItemId, ItemFull)] -> Int -> [(ItemId, Int, CStore, CStore)] -> m (FailOrCmd [(ItemId, Int, CStore, CStore)]) ret4 [] _ acc = return $ Right $ reverse acc @@ -742,7 +747,7 @@ case iid `EM.lookup` bag of Nothing -> failWith "no item to fling" Just kit -> do - itemToF <- itemToFullClient + itemToF <- getsState itemToFull let i = (fromCStore, (iid, itemToF iid kit)) projectItem ts i Nothing -> failWith "no item to fling" @@ -753,10 +758,8 @@ projectItem ts (fromCStore, (iid, itemFull)) = do leader <- getLeaderUI b <- getsState $ getActorBody leader - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) - calmE = calmEnough b ar + ar <- getsState $ getActorAspect leader + let calmE = calmEnough b ar if not calmE && fromCStore == CSha then failSer ItemNotCalm else do mpsuitReq <- psuitReq ts @@ -789,7 +792,7 @@ case iid `EM.lookup` bag of Nothing -> failWith "no item to apply" Just kit -> do - itemToF <- itemToFullClient + itemToF <- getsState itemToFull let i = (fromCStore, (iid, itemToF iid kit)) applyItem ts i Nothing -> failWith "no item to apply" @@ -800,10 +803,8 @@ applyItem ts (fromCStore, (iid, itemFull)) = do leader <- getLeaderUI b <- getsState $ getActorBody leader - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) - calmE = calmEnough b ar + ar <- getsState $ getActorAspect leader + let calmE = calmEnough b ar if not calmE && fromCStore == CSha then failSer ItemNotCalm else do p <- permittedApplyClient $ triggerSymbols ts @@ -817,13 +818,13 @@ alterDirHuman :: MonadClientUI m => [Trigger] -> m (FailOrCmd (RequestTimed 'AbAlter)) alterDirHuman ts = do - Config{configVi, configLaptop} <- getsSession sconfig + UIOptions{uVi, uLaptop} <- getsSession sUIOptions let verb1 = case ts of [] -> "alter" tr : _ -> verb tr keys = K.escKM : K.leftButtonReleaseKM - : map (K.KM K.NoModifier) (K.dirAllKey configVi configLaptop) + : map (K.KM K.NoModifier) (K.dirAllKey uVi uLaptop) prompt = makePhrase ["Where to", verb1 <> "? [movement key] [pointer]"] promptAdd prompt @@ -839,7 +840,7 @@ then alterTile ts dir else failWith "never mind" _ -> - case K.handleDir configVi configLaptop km of + case K.handleDir uVi uLaptop km of Nothing -> failWith "never mind" Just dir -> alterTile ts dir @@ -853,7 +854,7 @@ pText = compassText dir alterTileAtPos ts tpos pText --- | Try to alter a tile using a feature in at the given position. +-- | Try to alter a tile using a feature at the given position. alterTileAtPos :: MonadClientUI m => [Trigger] -> Point -> Text -> m (FailOrCmd (RequestTimed 'AbAlter)) @@ -898,7 +899,8 @@ let isE Item{jname} = jname == "escape" if | any isE is -> verifyEscape | null is && not (Tile.isDoor coTileSpeedup t - || Tile.isChangable coTileSpeedup t) -> + || Tile.isChangable coTileSpeedup t + || Tile.isSuspect coTileSpeedup t) -> failWith "never mind" | otherwise -> return $ Right () @@ -1000,10 +1002,8 @@ case iid `EM.lookup` bag of Nothing -> weaveJust <$> failWith "no item to open Item Menu for" Just kit -> do - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) - itemToF <- itemToFullClient + ar <- getsState $ getActorAspect leader + itemToF <- getsState itemToFull lidV <- viewedLevelUI Level{lxsize, lysize} <- getLevel lidV localTime <- getsState $ getLocalTime (blid b) @@ -1187,9 +1187,9 @@ gameMode <- getGameMode snxtScenario <- getsClient snxtScenario let nxtGameName = mname $ nxtGameMode cops snxtScenario - tnextScenario = "new scenario:" <+> nxtGameName + tnextScenario = "pick next:" <+> nxtGameName -- Key-description-command tuples. - kds = (K.mkKM "s", (tnextScenario, HumanCmd.GameScenarioIncr)) + kds = (K.mkKM "p", (tnextScenario, HumanCmd.GameScenarioIncr)) : [ (km, (desc, cmd)) | (km, ([HumanCmd.CmdMainMenu], desc, cmd)) <- bcmdList ] bindingLen = 30 @@ -1269,7 +1269,7 @@ , T.justifyLeft bindingLen ' ' tcurWolf , T.justifyLeft bindingLen ' ' tcurFish , T.justifyLeft bindingLen ' ' "" - , T.justifyLeft bindingLen ' ' "New game challenges:" + , T.justifyLeft bindingLen ' ' "Next game challenges:" , T.justifyLeft bindingLen ' ' "" ] generateMenu cmdAction kds gameInfo "challenge" diff --git a/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs b/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs --- a/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs +++ b/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs @@ -1,5 +1,7 @@ --- | Semantics of 'HumanCmd' client commands that do not return --- server commands. None of such commands takes game time. +-- | Semantics of "Game.LambdaHack.Client.UI.HumanCmd" +-- client commands that do not return server requests,, +-- but only change internal client state. +-- None of such commands takes game time. module Game.LambdaHack.Client.UI.HandleHumanLocalM ( -- * Meta commands macroHuman @@ -19,70 +21,75 @@ , xhairUnknownHuman, xhairItemHuman, xhairStairHuman , xhairPointerFloorHuman, xhairPointerEnemyHuman , aimPointerFloorHuman, aimPointerEnemyHuman +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , permittedProjectClient, projectCheck, xhairLegalEps, posFromXhair + , selectAid, endAiming, endAimingMsg, doLook, flashAiming + , xhairPointerFloor, xhairPointerEnemy +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude --- Cabal - import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M -import Data.Ord +import Data.Ord import qualified Data.Text as T import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Client.BfsM -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI.ActorUI -import Game.LambdaHack.Client.UI.Animation -import Game.LambdaHack.Client.UI.Config -import Game.LambdaHack.Client.UI.DrawM -import Game.LambdaHack.Client.UI.EffectDescription -import Game.LambdaHack.Client.UI.FrameM -import Game.LambdaHack.Client.UI.HandleHelperM -import Game.LambdaHack.Client.UI.HumanCmd (Trigger (..)) -import Game.LambdaHack.Client.UI.InventoryM -import Game.LambdaHack.Client.UI.ItemSlot +import Game.LambdaHack.Client.BfsM +import Game.LambdaHack.Client.CommonM +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI.ActorUI +import Game.LambdaHack.Client.UI.Animation +import Game.LambdaHack.Client.UI.DrawM +import Game.LambdaHack.Client.UI.EffectDescription +import Game.LambdaHack.Client.UI.FrameM +import Game.LambdaHack.Client.UI.HandleHelperM +import Game.LambdaHack.Client.UI.HumanCmd (Trigger (..)) +import Game.LambdaHack.Client.UI.InventoryM +import Game.LambdaHack.Client.UI.ItemDescription +import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.Msg -import Game.LambdaHack.Client.UI.MsgM -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.OverlayM -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Client.UI.SlideshowM -import Game.LambdaHack.Common.Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemStrongest +import Game.LambdaHack.Client.UI.MonadClientUI +import Game.LambdaHack.Client.UI.Msg +import Game.LambdaHack.Client.UI.MsgM +import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Client.UI.SlideshowM +import Game.LambdaHack.Client.UI.UIOptions +import Game.LambdaHack.Common.Ability +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.TileKind (isUknownSpace) +import Game.LambdaHack.Content.ModeKind (fhasGender) +import Game.LambdaHack.Content.TileKind (isUknownSpace) -- * Macro macroHuman :: MonadClientUI m => [String] -> m () macroHuman kms = do modifySession $ \sess -> sess {slastPlay = map K.mkKM kms ++ slastPlay sess} - Config{configRunStopMsgs} <- getsSession sconfig - when configRunStopMsgs $ + UIOptions{uRunStopMsgs} <- getsSession sUIOptions + when uRunStopMsgs $ promptAdd $ "Macro activated:" <+> T.pack (intercalate " " kms) -- * Clear @@ -173,10 +180,8 @@ Level{lxsize, lysize} <- getLevel lidV localTime <- getsState $ getLocalTime (blid b) factionD <- getsState sfactionD - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) - attrLine = itemDesc (bfid b) factionD (aHurtMelee ar) + ar <- getsState $ getActorAspect leader + let attrLine = itemDesc (bfid b) factionD (aHurtMelee ar) store localTime itemFull ov = splitAttrLine lxsize attrLine slides <- @@ -226,10 +231,8 @@ leader <- getLeaderUI b <- getsState $ getActorBody leader bUI <- getsSession $ getActorUI leader - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) - valueText = slotToDecorator eqpSlot b $ prEqpSlot eqpSlot ar + ar <- getsState $ getActorAspect leader + let valueText = slotToDecorator eqpSlot b $ prEqpSlot eqpSlot ar prompt2 = makeSentence [ MU.WownW (partActor bUI) (MU.Text $ slotToName eqpSlot) , "is", MU.Text valueText ] @@ -247,9 +250,7 @@ chooseItemProjectHuman ts = do leader <- getLeaderUI b <- getsState $ getActorBody leader - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) + ar <- getsState $ getActorAspect leader let calmE = calmEnough b ar cLegalRaw = [CGround, CInv, CSha, CEqp] cLegal | calmE = cLegalRaw @@ -279,11 +280,9 @@ permittedProjectClient triggerSyms = do leader <- getLeaderUI b <- getsState $ getActorBody leader + ar <- getsState $ getActorAspect leader actorSk <- leaderSkillsClientUI let skill = EM.findWithDefault 0 AbProject actorSk - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) calmE = calmEnough b ar return $ permittedProject False skill calmE triggerSyms @@ -330,13 +329,11 @@ findNewEps onlyFirst pos = do oldEps <- getsClient seps mnewEps <- makeLine onlyFirst b pos oldEps - case mnewEps of - Just newEps -> return $ Right newEps - Nothing -> - return $ Left - $ if onlyFirst - then "aiming blocked at the first step" - else "aiming line to the opponent blocked somewhere" + return $! case mnewEps of + Just newEps -> Right newEps + Nothing -> Left $ if onlyFirst + then "aiming blocked at the first step" + else "aiming line blocked somewhere" xhair <- getsSession sxhair case xhair of TEnemy a _ -> do @@ -349,14 +346,14 @@ return $ Left "selected opponent not visible" TPoint _ lid pos -> if lid == lidV - then findNewEps True pos + then findNewEps False pos else error $ "" `showFailure` (xhair, lidV) TVector v -> do Level{lxsize, lysize} <- getLevel lidV let shifted = shiftBounded lxsize lysize (bpos b) v if shifted == bpos b && v /= Vector 0 0 then return $ Left "selected translation is void" - else findNewEps True shifted + else findNewEps True shifted -- True, because the goal is vague anyway posFromXhair :: MonadClientUI m => m (Either Text Point) posFromXhair = do @@ -408,10 +405,8 @@ chooseItemApplyHuman ts = do leader <- getLeaderUI b <- getsState $ getActorBody leader - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) - calmE = calmEnough b ar + ar <- getsState $ getActorAspect leader + let calmE = calmEnough b ar cLegalRaw = [CGround, CInv, CSha, CEqp] cLegal | calmE = cLegalRaw | otherwise = delete CSha cLegalRaw @@ -437,11 +432,9 @@ permittedApplyClient triggerSyms = do leader <- getLeaderUI b <- getsState $ getActorBody leader + ar <- getsState $ getActorAspect leader actorSk <- leaderSkillsClientUI let skill = EM.findWithDefault 0 AbApply actorSk - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) calmE = calmEnough b ar localTime <- getsState $ getLocalTime (blid b) return $ permittedApply localTime skill calmE triggerSyms @@ -463,7 +456,7 @@ mactor = case drop k hs of [] -> Nothing (aid, b, _) : _ -> Just (aid, b) - mchoice = mhero `mplus` mactor + mchoice = if fhasGender (gplayer fact) then mhero else mactor (autoDun, _) = autoDungeonLevel fact case mchoice of Nothing -> failMsg "no such member of the party" @@ -481,13 +474,13 @@ -- * MemberCycle --- | Switches current member to the next on the viewed level, if any, wrapping. +-- | Switch current member to the next on the viewed level, if any, wrapping. memberCycleHuman :: MonadClientUI m => m MError memberCycleHuman = memberCycle True -- * MemberBack --- | Switches current member to the previous in the whole dungeon, wrapping. +-- | Switch current member to the previous in the whole dungeon, wrapping. memberBackHuman :: MonadClientUI m => m MError memberBackHuman = memberBack True @@ -496,10 +489,10 @@ selectActorHuman :: MonadClientUI m => m () selectActorHuman = do leader <- getLeaderUI - selectAidHuman leader + selectAid leader -selectAidHuman :: MonadClientUI m => ActorId -> m () -selectAidHuman leader = do +selectAid :: MonadClientUI m => ActorId -> m () +selectAid leader = do bodyUI <- getsSession $ getActorUI leader wasMemeber <- getsSession $ ES.member leader . sselected let upd = if wasMemeber @@ -548,11 +541,11 @@ | py == lysize + 2 -> case drop (px - 1) viewed of [] -> failMsg "not pointing at an actor" - (aid, _, _) : _ -> selectAidHuman aid >> return Nothing + (aid, _, _) : _ -> selectAid aid >> return Nothing | otherwise -> case find (\(_, b) -> bpos b == Point px (py - mapStartY)) ours of Nothing -> failMsg "not pointing at an actor" - Just (aid, _) -> selectAidHuman aid >> return Nothing + Just (aid, _) -> selectAid aid >> return Nothing -- * Repeat @@ -561,10 +554,10 @@ -- at terrain change or when walking over items. repeatHuman :: MonadClientUI m => Int -> m () repeatHuman n = do - (_, seqPrevious, k) <- getsSession slastRecord + LastRecord _ seqPrevious k <- getsSession slastRecord let macro = concat $ replicate n $ reverse seqPrevious modifySession $ \sess -> sess {slastPlay = macro ++ slastPlay sess} - let slastRecord = ([], [], if k == 0 then 0 else maxK) + let slastRecord = LastRecord [] [] (if k == 0 then 0 else maxK) modifySession $ \sess -> sess {slastRecord} maxK :: Int @@ -574,16 +567,16 @@ recordHuman :: MonadClientUI m => m () recordHuman = do - (_seqCurrent, seqPrevious, k) <- getsSession slastRecord + LastRecord _seqCurrent seqPrevious k <- getsSession slastRecord case k of 0 -> do - let slastRecord = ([], [], maxK) + let slastRecord = LastRecord [] [] maxK modifySession $ \sess -> sess {slastRecord} promptAdd $ "Macro will be recorded for up to" <+> tshow maxK <+> "actions. Stop recording with the same key." _ -> do - let slastRecord = (seqPrevious, [], 0) + let slastRecord = LastRecord seqPrevious [] 0 modifySession $ \sess -> sess {slastRecord} promptAdd $ "Macro recording stopped after" <+> tshow (maxK - k - 1) <+> "actions." @@ -739,7 +732,7 @@ map (\(aid2, b2) -> (aid2, b2, sactorUI EM.! aid2)) inhabitants seps <- getsClient seps mnewEps <- makeLine False b p seps - itemToF <- itemToFullClient + itemToF <- getsState itemToFull factionD <- getsState sfactionD s <- getState let aims = isJust mnewEps diff --git a/Game/LambdaHack/Client/UI/HandleHumanM.hs b/Game/LambdaHack/Client/UI/HandleHumanM.hs --- a/Game/LambdaHack/Client/UI/HandleHumanM.hs +++ b/Game/LambdaHack/Client/UI/HandleHumanM.hs @@ -1,24 +1,28 @@ -- | Semantics of human player commands. module Game.LambdaHack.Client.UI.HandleHumanM ( cmdHumanSem +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , noRemoteHumanCmd, cmdAction, addNoError, fmapTimedToUI +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude +import Game.LambdaHack.Client.Request import Game.LambdaHack.Client.UI.HandleHelperM import Game.LambdaHack.Client.UI.HandleHumanGlobalM import Game.LambdaHack.Client.UI.HandleHumanLocalM import Game.LambdaHack.Client.UI.HumanCmd import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Common.Request --- | The semantics of human player commands in terms of the @Action@ monad. --- Decides if the action takes time and what action to perform. --- Some time cosuming commands are enabled in aiming mode, but cannot be +-- | The semantics of human player commands in terms of the client monad. +-- +-- Some time cosuming commands are enabled even in aiming mode, but cannot be -- invoked in aiming mode on a remote level (level different than --- the level of the leader). +-- the level of the leader), which is caught here. cmdHumanSem :: MonadClientUI m => HumanCmd -> m (Either MError ReqUI) cmdHumanSem cmd = if noRemoteHumanCmd cmd then do @@ -32,7 +36,24 @@ else cmdAction cmd else cmdAction cmd --- | Compute the basic action for a command and mark whether it takes time. +-- | Commands that are forbidden on a remote level, because they +-- would usually take time when invoked on one, but not necessarily do +-- what the player expects. Note that some commands that normally take time +-- are not included, because they don't take time in aiming mode +-- or their individual sanity conditions include a remote level check. +noRemoteHumanCmd :: HumanCmd -> Bool +noRemoteHumanCmd cmd = case cmd of + Wait -> True + Wait10 -> True + MoveItem{} -> True + Apply{} -> True + AlterDir{} -> True + AlterWithPointer{} -> True + MoveOnceToXhair -> True + RunOnceToXhair -> True + ContinueToXhair -> True + _ -> False + cmdAction :: MonadClientUI m => HumanCmd -> m (Either MError ReqUI) cmdAction cmd = case cmd of Macro kms -> addNoError $ macroHuman kms @@ -50,8 +71,8 @@ LoopOnNothing cmd1 -> loopOnNothingHuman (cmdAction cmd1) - Wait -> weaveJust <$> Right <$> fmap timedToUI waitHuman - Wait10 -> weaveJust <$> Right <$> fmap timedToUI waitHuman10 + Wait -> weaveJust <$> Right <$> fmapTimedToUI waitHuman + Wait10 -> weaveJust <$> Right <$> fmapTimedToUI waitHuman10 MoveDir v -> weaveJust <$> (ReqUITimed <$$> moveRunHuman True True False False v) RunDir v -> weaveJust <$> (ReqUITimed <$$> moveRunHuman True True True True v) @@ -60,11 +81,13 @@ RunOnceToXhair -> weaveJust <$> (ReqUITimed <$$> runOnceToXhairHuman) ContinueToXhair -> weaveJust <$> (ReqUITimed <$$> continueToXhairHuman) MoveItem cLegalRaw toCStore mverb auto -> - weaveJust <$> (timedToUI <$$> moveItemHuman cLegalRaw toCStore mverb auto) - Project ts -> weaveJust <$> (timedToUI <$$> projectHuman ts) - Apply ts -> weaveJust <$> (timedToUI <$$> applyHuman ts) - AlterDir ts -> weaveJust <$> (timedToUI <$$> alterDirHuman ts) - AlterWithPointer ts -> weaveJust <$> (timedToUI <$$> alterWithPointerHuman ts) + weaveJust + <$> (fmapTimedToUI <$> moveItemHuman cLegalRaw toCStore mverb auto) + Project ts -> weaveJust <$> (fmapTimedToUI <$> projectHuman ts) + Apply ts -> weaveJust <$> (fmapTimedToUI <$> applyHuman ts) + AlterDir ts -> weaveJust <$> (fmapTimedToUI <$> alterDirHuman ts) + AlterWithPointer ts -> weaveJust + <$> (fmapTimedToUI <$> alterWithPointerHuman ts) Help -> helpHuman cmdAction ItemMenu -> itemMenuHuman cmdAction ChooseItemMenu dialogMode -> chooseItemMenuHuman cmdAction dialogMode @@ -122,3 +145,6 @@ addNoError :: Monad m => m () -> m (Either MError ReqUI) addNoError cmdCli = cmdCli >> return (Left Nothing) + +fmapTimedToUI :: Monad m => m (RequestTimed a) -> m ReqUI +fmapTimedToUI mr = ReqUITimed . RequestAnyAbility <$> mr diff --git a/Game/LambdaHack/Client/UI/HumanCmd.hs b/Game/LambdaHack/Client/UI/HumanCmd.hs --- a/Game/LambdaHack/Client/UI/HumanCmd.hs +++ b/Game/LambdaHack/Client/UI/HumanCmd.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} --- | Abstract syntax human player commands. +-- | Abstract syntax of human player commands. module Game.LambdaHack.Client.UI.HumanCmd ( CmdCategory(..), categoryDescription , CmdArea(..), areaDescription - , CmdTriple, HumanCmd(..), noRemoteHumanCmd + , CmdTriple, HumanCmd(..) , Trigger(..) ) where @@ -11,13 +11,13 @@ import Game.LambdaHack.Common.Prelude -import Control.DeepSeq -import Data.Binary -import GHC.Generics (Generic) +import Control.DeepSeq +import Data.Binary +import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.TileKind as TK data CmdCategory = @@ -45,6 +45,8 @@ -- The constructors are sorted, roughly, wrt inclusion, then top to bottom, -- the left to right. +-- | Symbolic representation of areas of the screen used to define the meaning +-- of mouse button presses relative to where the mouse points to. data CmdArea = CaMessage | CaMapLeader @@ -80,9 +82,12 @@ CaTargetDesc -> "target info" -- 1234567890123 +-- | This triple of command categories, description and the command term itself +-- defines the meaning of a human command as entered via a keypress, +-- mouse click or chosen from a menu. type CmdTriple = ([CmdCategory], Text, HumanCmd) --- | Abstract syntax of player commands. +-- | Abstract syntax of human player commands. data HumanCmd = -- Meta. Macro [String] @@ -168,24 +173,8 @@ instance Binary HumanCmd --- | Commands that are forbidden on a remote level, because they --- would usually take time when invoked on one, but not necessarily do --- what the player expects. Note that some commands that normally take time --- are not included, because they don't take time in aiming mode --- or their individual sanity conditions include a remote level check. -noRemoteHumanCmd :: HumanCmd -> Bool -noRemoteHumanCmd cmd = case cmd of - Wait -> True - Wait10 -> True - MoveItem{} -> True - Apply{} -> True - AlterDir{} -> True - AlterWithPointer{} -> True - MoveOnceToXhair -> True - RunOnceToXhair -> True - ContinueToXhair -> True - _ -> False - +-- | Description of how item manipulation is triggered and communicated +-- to the player. data Trigger = ApplyItem {verb :: MU.Part, object :: MU.Part, symbol :: Char} | AlterFeature {verb :: MU.Part, object :: MU.Part, feature :: TK.Feature} diff --git a/Game/LambdaHack/Client/UI/InventoryM.hs b/Game/LambdaHack/Client/UI/InventoryM.hs --- a/Game/LambdaHack/Client/UI/InventoryM.hs +++ b/Game/LambdaHack/Client/UI/InventoryM.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DataKinds #-} --- | Inventory management and party cycling. +-- | UI of inventory management. module Game.LambdaHack.Client.UI.InventoryM ( Suitability(..) , getFull, getGroupItem, getStoreItem @@ -14,37 +14,36 @@ import Game.LambdaHack.Common.Prelude import qualified Data.Char as Char -import Data.Either +import Data.Either import qualified Data.EnumMap.Strict as EM import qualified Data.Map.Strict as M import qualified Data.Text as T -import Data.Tuple (swap) +import Data.Tuple (swap) import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI.ActorUI -import Game.LambdaHack.Client.UI.HandleHelperM -import Game.LambdaHack.Client.UI.HumanCmd -import Game.LambdaHack.Client.UI.ItemSlot +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI.ActorUI +import Game.LambdaHack.Client.UI.HandleHelperM +import Game.LambdaHack.Client.UI.HumanCmd +import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.KeyBindings -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.MsgM -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Client.UI.Slideshow -import Game.LambdaHack.Client.UI.SlideshowM -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State +import Game.LambdaHack.Client.UI.KeyBindings +import Game.LambdaHack.Client.UI.MonadClientUI +import Game.LambdaHack.Client.UI.MsgM +import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Client.UI.Slideshow +import Game.LambdaHack.Client.UI.SlideshowM +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State data ItemDialogState = ISuitable | IAll deriving (Show, Eq) @@ -173,7 +172,7 @@ return $ Left $ "no items" <+> ppLegal else return $ Left $ showReqFailure ItemNotCalm haveThis@(headThisActor : _) -> do - itemToF <- itemToFullClient + itemToF <- getsState itemToFull let suitsThisActor store = let bag = getCStoreBag store in any (\(iid, kit) -> psuitFun $ itemToF iid kit) $ EM.assocs bag @@ -216,7 +215,7 @@ allAssocs = concatMap storeAssocs (cCur : cRest) case (cRest, allAssocs) of ([], [(iid, k)]) | not askWhenLone -> do - itemToF <- itemToFullClient + itemToF <- getsState itemToFull ItemSlots itemSlots organSlots <- getsSession sslots let isOrgan = cCur `elem` [MStore COrgan, MLoreOrgan] lSlots = if isOrgan then organSlots else itemSlots @@ -258,13 +257,11 @@ leader <- getLeaderUI body <- getsState $ getActorBody leader bodyUI <- getsSession $ getActorUI leader - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) + ar <- getsState $ getActorAspect leader fact <- getsState $ (EM.! bfid body) . sfactionD hs <- partyAfterLeader leader bagAll <- getsState $ \s -> accessModeBag leader s cCur - itemToF <- itemToFullClient + itemToF <- getsState itemToFull Binding{brevMap} <- getsSession sbinding mpsuit <- psuit -- when throwing, this sets eps and checks xhair validity psuitFun <- case mpsuit of @@ -458,10 +455,8 @@ leader <- getLeaderUI let newLegal = cCur : cRest -- not updated in any way yet b <- getsState $ getActorBody leader - actorAspect <- getsClient sactorAspect - let ar = fromMaybe (error $ "" `showFailure` leader) - (EM.lookup leader actorAspect) - calmE = calmEnough b ar + ar <- getsState $ getActorAspect leader + let calmE = calmEnough b ar legalAfterCalm = case newLegal of c1@(MStore CSha) : c2 : rest | not calmE -> (c2, c1 : rest) [MStore CSha] | not calmE -> (MStore CGround, newLegal) diff --git a/Game/LambdaHack/Client/UI/ItemDescription.hs b/Game/LambdaHack/Client/UI/ItemDescription.hs --- a/Game/LambdaHack/Client/UI/ItemDescription.hs +++ b/Game/LambdaHack/Client/UI/ItemDescription.hs @@ -2,7 +2,11 @@ module Game.LambdaHack.Client.UI.ItemDescription ( partItem, partItemShort, partItemHigh, partItemWs, partItemWsRanged , partItemShortAW, partItemMediumAW, partItemShortWownW - , viewItem, show64With2 + , viewItem, itemDesc +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , show64With2, partItemN, textAllAE, partItemWsR +#endif ) where import Prelude () @@ -10,19 +14,20 @@ import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM -import Data.Int (Int64) +import Data.Int (Int64) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Client.UI.EffectDescription +import Game.LambdaHack.Client.UI.EffectDescription +import Game.LambdaHack.Client.UI.Overlay import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Flavour -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemStrongest -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Flavour +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.ItemStrongest +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Time import qualified Game.LambdaHack.Content.ItemKind as IK show64With2 :: Int64 -> Text @@ -148,11 +153,11 @@ _ -> [] damage = case find hurtMeleeAspect aspects of Just (IK.AddHurtMelee hurtMelee) -> - (if jdamage itemBase <= 0 + (if jdamage itemBase == 0 then "0d0" else tshow (jdamage itemBase)) <> affixDice hurtMelee <> "%" - _ -> if jdamage itemBase <= 0 + _ -> if jdamage itemBase == 0 then "" else tshow (jdamage itemBase) in elab ++ if fullInfo >= 6 || fullInfo >= 2 && null elab @@ -166,12 +171,12 @@ splitAE (IK.iaspects itemKind) (IK.ieffects itemKind) IK.ThrowMod{IK.throwVelocity} = strengthToThrow itemBase speed = speedFromWeight (jweight itemBase) throwVelocity - meanDmg = Dice.meanDice (jdamage itemBase) + meanDmg = ceiling $ Dice.meanDice (jdamage itemBase) minDeltaHP = xM meanDmg `divUp` 100 aHurtMeleeOfItem = case itemAspect of Just aspectRecord -> aHurtMelee aspectRecord Nothing -> case find hurtMeleeAspect (IK.iaspects itemKind) of - Just (IK.AddHurtMelee d) -> Dice.meanDice d + Just (IK.AddHurtMelee d) -> ceiling $ Dice.meanDice d _ -> 0 pmult = 100 + min 99 (max (-99) aHurtMeleeOfItem) prawDeltaHP = fromIntegral pmult * minDeltaHP @@ -244,3 +249,101 @@ {-# INLINE viewItem #-} viewItem item = Color.attrChar2ToW32 (flavourToColor $ jflavour item) (jsymbol item) + +itemDesc :: FactionId -> FactionDict -> Int -> CStore -> Time -> ItemFull + -> AttrLine +itemDesc side factionD aHurtMeleeOfOwner store localTime + itemFull@ItemFull{itemBase} = + let (_, unique, name, stats) = + partItemHigh side factionD store localTime itemFull + nstats = makePhrase [name, stats] + IK.ThrowMod{IK.throwVelocity, IK.throwLinger} = strengthToThrow itemBase + speed = speedFromWeight (jweight itemBase) throwVelocity + range = rangeFromSpeedAndLinger speed throwLinger + tspeed | speed < speedLimp = "When thrown, it drops at once." + | speed < speedWalk = "When thrown, it travels only one meter and drops immediately." + | otherwise = + "When thrown, it flies with speed of" + <+> tshow (fromSpeed speed `div` 10) + <> if throwLinger /= 100 + then " m/s and range" <+> tshow range <+> "m." + else " m/s." + (desc, featureSentences, damageAnalysis) = case itemDisco itemFull of + Nothing -> ("This item is as unremarkable as can be.", "", tspeed) + Just ItemDisco{itemKind, itemAspect} -> + let sentences = mapMaybe featureToSentence (IK.ifeature itemKind) + hurtMeleeAspect :: IK.Aspect -> Bool + hurtMeleeAspect IK.AddHurtMelee{} = True + hurtMeleeAspect _ = False + aHurtMeleeOfItem = case itemAspect of + Just aspectRecord -> aHurtMelee aspectRecord + Nothing -> case find hurtMeleeAspect (IK.iaspects itemKind) of + Just (IK.AddHurtMelee d) -> ceiling $ Dice.meanDice d + _ -> 0 + meanDmg = ceiling $ Dice.meanDice (jdamage itemBase) + dmgAn = if meanDmg <= 0 then "" else + let multRaw = aHurtMeleeOfOwner + + if store `elem` [CEqp, COrgan] + then 0 + else aHurtMeleeOfItem + mult = 100 + min 99 (max (-99) multRaw) + minDeltaHP = xM meanDmg `divUp` 100 + rawDeltaHP = fromIntegral mult * minDeltaHP + pmult = 100 + min 99 (max (-99) aHurtMeleeOfItem) + prawDeltaHP = fromIntegral pmult * minDeltaHP + pdeltaHP = modifyDamageBySpeed prawDeltaHP speed + mDeltaHP = modifyDamageBySpeed minDeltaHP speed + in "Against defenceless targets you would inflict around" + -- rounding and non-id items + <+> tshow meanDmg + <> "*" <> tshow mult <> "%" + <> "=" <> show64With2 rawDeltaHP + <+> "melee damage (min" <+> show64With2 minDeltaHP + <> ") and" + <+> tshow meanDmg + <> "*" <> tshow pmult <> "%" + <> "*" <> "speed^2" + <> "/" <> tshow (fromSpeed speedThrust `divUp` 10) <> "^2" + <> "=" <> show64With2 pdeltaHP + <+> "ranged damage (min" <+> show64With2 mDeltaHP + <> ") with it" + <> if Dice.minDice (jdamage itemBase) + == Dice.maxDice (jdamage itemBase) + then "." + else "on average." + in (IK.idesc itemKind, T.intercalate " " sentences, tspeed <+> dmgAn) + eqpSlotSentence = case strengthEqpSlot itemFull of + Just es -> slotToSentence es + Nothing -> "" + weight = jweight itemBase + (scaledWeight, unitWeight) + | weight > 1000 = + (tshow $ fromIntegral weight / (1000 :: Double), "kg") + | otherwise = (tshow weight, "g") + onLevel = "on level" <+> tshow (abs $ fromEnum $ jlid itemBase) <> "." + discoFirst = (if unique then "Discovered" else "First seen") + <+> onLevel + whose fid = gname (factionD EM.! fid) + sourceDesc = + case jfid itemBase of + Just fid | jsymbol itemBase `elem` ['+'] -> + "Caused by" <+> (if fid == side then "us" else whose fid) + <> ". First observed" <+> onLevel + Just fid -> + "Coming from" <+> whose fid + <> "." <+> discoFirst + _ -> discoFirst + colorSymbol = viewItem itemBase + blurb = + " " + <> nstats + <> ":" + <+> desc + <+> (if weight > 0 + then makeSentence ["Weighs", MU.Text scaledWeight <> unitWeight] + else "") + <+> featureSentences + <+> eqpSlotSentence + <+> sourceDesc + <+> damageAnalysis + in colorSymbol : textToAL blurb diff --git a/Game/LambdaHack/Client/UI/ItemSlot.hs b/Game/LambdaHack/Client/UI/ItemSlot.hs --- a/Game/LambdaHack/Client/UI/ItemSlot.hs +++ b/Game/LambdaHack/Client/UI/ItemSlot.hs @@ -1,6 +1,6 @@ -- | Item slots for UI and AI item collections. module Game.LambdaHack.Client.UI.ItemSlot - ( ItemSlots(..), SlotChar(..) + ( SlotChar(..), ItemSlots(..) , allSlots, allZeroSlots, intSlots, slotLabel, assignSlot ) where @@ -8,12 +8,12 @@ import Game.LambdaHack.Common.Prelude -import Data.Binary -import Data.Bits (unsafeShiftL, unsafeShiftR) -import Data.Char +import Data.Binary +import Data.Bits (unsafeShiftL, unsafeShiftR) +import Data.Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Ord (comparing) +import Data.Ord (comparing) import qualified Data.Text as T import Game.LambdaHack.Common.Actor @@ -23,6 +23,7 @@ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.State +-- | Slot label. Usually just a character. Sometimes with a numerical prefix. data SlotChar = SlotChar {slotPrefix :: Int, slotChar :: Char} deriving (Show, Eq) @@ -42,8 +43,10 @@ c100 = c0 - if c0 > 150 then 100 else 0 in SlotChar n (chr c100) -data ItemSlots = ItemSlots (EM.EnumMap SlotChar ItemId) - (EM.EnumMap SlotChar ItemId) +-- | Mapping from slot labels to item identifiers. +data ItemSlots = ItemSlots + { itemSlots :: EM.EnumMap SlotChar ItemId + , organSlots :: EM.EnumMap SlotChar ItemId } deriving Show instance Binary ItemSlots where @@ -59,6 +62,12 @@ intSlots :: [SlotChar] intSlots = map (flip SlotChar 'a') [0..] +slotLabel :: SlotChar -> Text +slotLabel x = + T.snoc (if slotPrefix x == 0 then T.empty else tshow $ slotPrefix x) + (slotChar x) + <> ")" + -- | Assigns a slot to an item, for inclusion in the inventory -- of a hero. Tries to to use the requested slot, if any. assignSlot :: CStore -> Item -> FactionId -> Maybe Actor -> ItemSlots @@ -85,9 +94,3 @@ free = filter f candidates g l = l `EM.notMember` lSlots fresh = filter g $ take ((slotPrefix lastSlot + 1) * len0) candidates - -slotLabel :: SlotChar -> Text -slotLabel x = - T.snoc (if slotPrefix x == 0 then T.empty else tshow $ slotPrefix x) - (slotChar x) - <> ")" diff --git a/Game/LambdaHack/Client/UI/Key.hs b/Game/LambdaHack/Client/UI/Key.hs --- a/Game/LambdaHack/Client/UI/Key.hs +++ b/Game/LambdaHack/Client/UI/Key.hs @@ -1,25 +1,34 @@ {-# LANGUAGE DeriveGeneric #-} -- | Frontend-independent keyboard input operations. module Game.LambdaHack.Client.UI.Key - ( Key(..), showKey, handleDir, dirAllKey - , moveBinding, mkKM, mkChar, mkKP, keyTranslate, keyTranslateWeb - , Modifier(..), KM(..), showKM + ( Key(..), Modifier(..), KM(..), KMP(..) + , showKey, showKM , escKM, spaceKM, safeSpaceKM, returnKM , pgupKM, pgdnKM, wheelNorthKM, wheelSouthKM , upKM, downKM, leftKM, rightKM , homeKM, endKM, backspaceKM , leftButtonReleaseKM, rightButtonReleaseKM + , dirAllKey, handleDir, moveBinding, mkKM, mkChar, mkKP + , keyTranslate, keyTranslateWeb +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , dirKeypadKey, dirKeypadShiftChar, dirKeypadShiftKey + , dirLaptopKey, dirLaptopShiftKey + , dirViChar, dirViKey, dirViShiftKey + , dirMoveNoModifier, dirRunNoModifier, dirRunControl, dirRunShift +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude hiding (Alt, Left, Right) -import Control.DeepSeq -import Data.Binary +import Control.DeepSeq +import Data.Binary import qualified Data.Char as Char -import GHC.Generics (Generic) +import GHC.Generics (Generic) +import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Vector -- | Frontend-independent datatype to represent keys. @@ -72,6 +81,7 @@ instance NFData Modifier +-- | Key and modifier. data KM = KM { modifier :: Modifier , key :: Key } deriving (Ord, Eq, Generic) @@ -83,7 +93,11 @@ instance Show KM where show = showKM --- Common and terse names for keys. +-- | Key, modifier and position of mouse pointer. +data KMP = KMP { kmpKeyMod :: KM + , kmpPointer :: Point } + +-- | Common and terse names for keys. showKey :: Key -> String showKey Esc = "ESC" showKey Return = "RET" @@ -199,15 +213,15 @@ dirViShiftKey = map (Char . Char.toUpper) dirViChar dirMoveNoModifier :: Bool -> Bool -> [Key] -dirMoveNoModifier configVi configLaptop = - dirKeypadKey ++ if | configVi -> dirViKey - | configLaptop -> dirLaptopKey +dirMoveNoModifier uVi uLaptop = + dirKeypadKey ++ if | uVi -> dirViKey + | uLaptop -> dirLaptopKey | otherwise -> [] dirRunNoModifier :: Bool -> Bool -> [Key] -dirRunNoModifier configVi configLaptop = - dirKeypadShiftKey ++ if | configVi -> dirViShiftKey - | configLaptop -> dirLaptopShiftKey +dirRunNoModifier uVi uLaptop = + dirKeypadShiftKey ++ if | uVi -> dirViShiftKey + | uLaptop -> dirLaptopShiftKey | otherwise -> [] dirRunControl :: [Key] @@ -219,30 +233,30 @@ dirRunShift = dirRunControl dirAllKey :: Bool -> Bool -> [Key] -dirAllKey configVi configLaptop = - dirMoveNoModifier configVi configLaptop - ++ dirRunNoModifier configVi configLaptop +dirAllKey uVi uLaptop = + dirMoveNoModifier uVi uLaptop + ++ dirRunNoModifier uVi uLaptop ++ dirRunControl -- | Configurable event handler for the direction keys. -- Used for directed commands such as close door. handleDir :: Bool -> Bool -> KM -> Maybe Vector -handleDir configVi configLaptop KM{modifier=NoModifier, key} = - let assocs = zip (dirAllKey configVi configLaptop) $ cycle moves +handleDir uVi uLaptop KM{modifier=NoModifier, key} = + let assocs = zip (dirAllKey uVi uLaptop) $ cycle moves in lookup key assocs handleDir _ _ _ = Nothing --- | Binding of both sets of movement keys. +-- | Binding of both sets of movement keys, vi and laptop. moveBinding :: Bool -> Bool -> (Vector -> a) -> (Vector -> a) -> [(KM, a)] -moveBinding configVi configLaptop move run = +moveBinding uVi uLaptop move run = let assign f (km, dir) = (km, f dir) mapMove modifier keys = map (assign move) (zip (map (KM modifier) keys) $ cycle moves) mapRun modifier keys = map (assign run) (zip (map (KM modifier) keys) $ cycle moves) - in mapMove NoModifier (dirMoveNoModifier configVi configLaptop) - ++ mapRun NoModifier (dirRunNoModifier configVi configLaptop) + in mapMove NoModifier (dirMoveNoModifier uVi uLaptop) + ++ mapRun NoModifier (dirRunNoModifier uVi uLaptop) ++ mapRun Control dirRunControl ++ mapRun Shift dirRunShift diff --git a/Game/LambdaHack/Client/UI/KeyBindings.hs b/Game/LambdaHack/Client/UI/KeyBindings.hs --- a/Game/LambdaHack/Client/UI/KeyBindings.hs +++ b/Game/LambdaHack/Client/UI/KeyBindings.hs @@ -1,6 +1,5 @@ {-# LANGUAGE TupleSections #-} --- | Binding of keys to commands. --- No operation in this module involves the 'State' or 'Action' type. +-- | Verifying, aggregating and displaying binding of keys to commands. module Game.LambdaHack.Client.UI.KeyBindings ( Binding(..), stdBinding, keyHelp, okxsN ) where @@ -12,13 +11,13 @@ import qualified Data.Map.Strict as M import qualified Data.Text as T -import Game.LambdaHack.Client.UI.Config -import Game.LambdaHack.Client.UI.Content.KeyKind -import Game.LambdaHack.Client.UI.HumanCmd -import Game.LambdaHack.Client.UI.ItemSlot +import Game.LambdaHack.Client.UI.Content.KeyKind +import Game.LambdaHack.Client.UI.HumanCmd +import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.Slideshow +import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.Slideshow +import Game.LambdaHack.Client.UI.UIOptions import qualified Game.LambdaHack.Common.Color as Color -- | Bindings and other information about human player commands. @@ -29,36 +28,36 @@ , brevMap :: M.Map HumanCmd [K.KM] -- ^ and from commands to their keys } --- | Binding of keys to movement and other standard commands, +-- | Create binding of keys to movement and other standard commands, -- as well as commands defined in the config file. -stdBinding :: KeyKind -- ^ default key bindings from the content - -> Config -- ^ game config - -> Binding -- ^ concrete binding -stdBinding copsClient Config{configCommands, configVi, configLaptop} = +stdBinding :: KeyKind -- ^ default key bindings from the content + -> UIOptions -- ^ UI client options + -> Binding -- ^ concrete binding +stdBinding (KeyKind copsClient) UIOptions{uCommands, uVi, uLaptop} = let waitTriple = ([CmdMove], "", Wait) wait10Triple = ([CmdMove], "", Wait10) moveXhairOr n cmd v = ByAimMode { exploration = cmd v , aiming = MoveXhair v n } bcmdList = - (if configVi + (if uVi then filter (\(k, _) -> k `notElem` [K.mkKM "period", K.mkKM "C-period"]) - else id) (rhumanCommands copsClient) - ++ configCommands + else id) copsClient + ++ uCommands ++ [ (K.mkKM "KP_Begin", waitTriple) , (K.mkKM "C-KP_Begin", wait10Triple) , (K.mkKM "KP_5", waitTriple) , (K.mkKM "C-KP_5", wait10Triple) ] - ++ (if | configVi -> + ++ (if | uVi -> [ (K.mkKM "period", waitTriple) , (K.mkKM "C-period", wait10Triple) ] - | configLaptop -> + | uLaptop -> [ (K.mkKM "i", waitTriple) , (K.mkKM "C-i", wait10Triple) , (K.mkKM "I", waitTriple) ] | otherwise -> []) - ++ K.moveBinding configVi configLaptop + ++ K.moveBinding uVi uLaptop (\v -> ([CmdMove], "", moveXhairOr 1 MoveDir v)) (\v -> ([CmdMove], "", moveXhairOr 10 RunDir v)) rejectRepetitions t1 t2 = error $ "duplicate key" @@ -77,7 +76,7 @@ ] } --- | Produce a set of help screens from the key bindings. +-- | Produce a set of help/menu screens from the key bindings. keyHelp :: Binding -> Int -> [(Text, OKX)] keyHelp keyb@Binding{..} offset = assert (offset > 0) $ let @@ -242,6 +241,7 @@ [areaCaption] lastHelpEnd ) ] +-- | Turn the specified portion of bindings into a menu. okxsN :: Binding -> Int -> Int -> (HumanCmd -> Bool) -> CmdCategory -> [Text] -> [Text] -> OKX okxsN Binding{..} offset n greyedOut cat header footer = diff --git a/Game/LambdaHack/Client/UI/MonadClientUI.hs b/Game/LambdaHack/Client/UI/MonadClientUI.hs --- a/Game/LambdaHack/Client/UI/MonadClientUI.hs +++ b/Game/LambdaHack/Client/UI/MonadClientUI.hs @@ -1,20 +1,25 @@ -- | Client monad for interacting with a human through UI. module Game.LambdaHack.Client.UI.MonadClientUI ( -- * Client UI monad - MonadClientUI( getsSession, modifySession + MonadClientUI( getsSession + , modifySession , liftIO -- exposed only to be implemented, not used, ) -- * Assorted primitives - , getSession, putSession, clientPrintUI, mapStartY, displayFrames - , setFrontAutoYes, anyKeyPressed, discardPressedKey, addPressedEsc - , connFrontendFrontKey, frontendShutdown, chanFrontend + , clientPrintUI, mapStartY, getSession, putSession, displayFrames + , connFrontendFrontKey, setFrontAutoYes, frontendShutdown, chanFrontend + , anyKeyPressed, discardPressedKey, addPressedEsc , getReportUI, getLeaderUI, getArenaUI, viewedLevelUI , leaderTgtToPos, xhairToPos, clearXhair, clearAimMode , scoreToSlideshow, defaultHistory , tellAllClipPS, tellGameClipPS, elapsedSessionTimeGT , resetSessionStart, resetGameStart - , partAidLeader, partActorLeader, partActorLeaderFun, partPronounLeader + , partActorLeader, partActorLeaderFun, partPronounLeader, partAidLeader , tryRestore, leaderSkillsClientUI +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , connFrontend, displayFrame, addPressedKey +#endif ) where import Prelude () @@ -24,42 +29,42 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Time.Clock -import Data.Time.Clock.POSIX -import Data.Time.LocalTime +import Data.Time.Clock +import Data.Time.Clock.POSIX +import Data.Time.LocalTime import qualified NLP.Miniutter.English as MU -import System.FilePath -import System.IO (hFlush, stdout) +import System.FilePath +import System.IO (hFlush, stdout) -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient hiding (liftIO) -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI.ActorUI -import Game.LambdaHack.Client.UI.Frame -import Game.LambdaHack.Client.UI.Frontend +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client.CommonM +import Game.LambdaHack.Client.MonadClient hiding (liftIO) +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI.ActorUI +import Game.LambdaHack.Client.UI.Frame +import Game.LambdaHack.Client.UI.Frontend import qualified Game.LambdaHack.Client.UI.Frontend as Frontend import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.Msg -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Client.UI.Slideshow +import Game.LambdaHack.Client.UI.Msg +import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Client.UI.Slideshow import qualified Game.LambdaHack.Common.Ability as Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.ClientOptions -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.File +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.File import qualified Game.LambdaHack.Common.HighScore as HighScore import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.Save as Save -import Game.LambdaHack.Common.State -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.RuleKind +import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.RuleKind -- Assumes no interleaving with other clients, because each UI client -- in a different terminal/window/machine. @@ -115,34 +120,35 @@ connFrontendFrontKey :: MonadClientUI m => [K.KM] -> FrameForall -> m K.KM connFrontendFrontKey frontKeyKeys frontKeyFrame = do kmp <- connFrontend FrontKey{..} - modifySession $ \sess -> sess {spointer = kmpPointer kmp} - return $! kmpKeyMod kmp + modifySession $ \sess -> sess {spointer = K.kmpPointer kmp} + return $! K.kmpKeyMod kmp setFrontAutoYes :: MonadClientUI m => Bool -> m () setFrontAutoYes b = connFrontend $ FrontAutoYes b +frontendShutdown :: MonadClientUI m => m () +frontendShutdown = connFrontend FrontShutdown + +-- | Initialize the frontend chosen by the player via client options. +chanFrontend :: MonadClientUI m => ClientOptions -> m ChanFrontend +chanFrontend = liftIO . Frontend.chanFrontendIO + anyKeyPressed :: MonadClientUI m => m Bool anyKeyPressed = connFrontend FrontPressed discardPressedKey :: MonadClientUI m => m () discardPressedKey = connFrontend FrontDiscard -addPressedKey :: MonadClientUI m => KMP -> m () +addPressedKey :: MonadClientUI m => K.KMP -> m () addPressedKey = connFrontend . FrontAdd addPressedEsc :: MonadClientUI m => m () -addPressedEsc = addPressedKey KMP { kmpKeyMod = K.escKM - , kmpPointer = originPoint } - -frontendShutdown :: MonadClientUI m => m () -frontendShutdown = connFrontend FrontShutdown - -chanFrontend :: MonadClientUI m => DebugModeCli -> m ChanFrontend -chanFrontend = liftIO . Frontend.chanFrontendIO +addPressedEsc = addPressedKey K.KMP { K.kmpKeyMod = K.escKM + , K.kmpPointer = originPoint } getReportUI :: MonadClientUI m => m Report getReportUI = do - report <- getsSession _sreport + report <- getsSession sreport side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD let underAI = isAIFact fact @@ -152,7 +158,7 @@ getLeaderUI :: MonadClientUI m => m ActorId getLeaderUI = do cli <- getClient - case _sleader cli of + case sleader cli of Nothing -> error $ "leader expected but not found" `showFailure` cli Just leader -> return leader @@ -164,7 +170,7 @@ case gquit fact of Just Status{stDepth} -> return $! toEnum stDepth Nothing -> getEntryArena fact - mleader <- getsClient _sleader + mleader <- getsClient sleader case mleader of Just leader -> do -- The leader may just be teleporting (e.g., due to displace @@ -184,7 +190,7 @@ leaderTgtToPos :: MonadClientUI m => m (Maybe Point) leaderTgtToPos = do lidV <- viewedLevelUI - mleader <- getsClient _sleader + mleader <- getsClient sleader case mleader of Nothing -> return Nothing Just aid -> do @@ -196,7 +202,7 @@ xhairToPos :: MonadClientUI m => m (Maybe Point) xhairToPos = do lidV <- viewedLevelUI - mleader <- getsClient _sleader + mleader <- getsClient sleader sxhair <- getsSession sxhair case mleader of Nothing -> return Nothing -- e.g., when game start and no leader yet @@ -269,18 +275,18 @@ else emptySlideshow defaultHistory :: MonadClientUI m => Int -> m History -defaultHistory configHistoryMax = liftIO $ do +defaultHistory uHistoryMax = liftIO $ do utcTime <- getCurrentTime timezone <- getTimeZone utcTime let curDate = show $ utcToLocalTime timezone utcTime - emptyHist = emptyHistory configHistoryMax + emptyHist = emptyHistory uHistoryMax return $! addReport emptyHist timeZero $ singletonReport $ toMsg $ stringToAL $ "Human history log started on " ++ curDate ++ "." tellAllClipPS :: MonadClientUI m => m () tellAllClipPS = do - bench <- getsClient $ sbenchmark . sdebugCli + bench <- getsClient $ sbenchmark . soptions when bench $ do sstartPOSIX <- getsSession sstart curPOSIX <- liftIO getPOSIXTime @@ -300,7 +306,7 @@ tellGameClipPS :: MonadClientUI m => m () tellGameClipPS = do - bench <- getsClient $ sbenchmark . sdebugCli + bench <- getsClient $ sbenchmark . soptions when bench $ do sgstartPOSIX <- getsSession sgstart curPOSIX <- liftIO getPOSIXTime @@ -344,14 +350,14 @@ -- of the client's faction. The actor may be not present in the dungeon. partActorLeader :: MonadClientUI m => ActorId -> ActorUI -> m MU.Part partActorLeader aid b = do - mleader <- getsClient _sleader + mleader <- getsClient sleader return $! case mleader of Just leader | aid == leader -> "you" _ -> partActor b partActorLeaderFun :: MonadClientUI m => m (ActorId -> MU.Part) partActorLeaderFun = do - mleader <- getsClient _sleader + mleader <- getsClient sleader sess <- getSession return $! \aid -> if mleader == Just aid @@ -362,7 +368,7 @@ -- of the client's faction. The actor may be not present in the dungeon. partPronounLeader :: MonadClient m => ActorId -> ActorUI -> m MU.Part partPronounLeader aid b = do - mleader <- getsClient _sleader + mleader <- getsClient sleader return $! case mleader of Just leader | aid == leader -> "you" _ -> partPronoun b @@ -375,14 +381,15 @@ b <- getsSession $ getActorUI aid partActorLeader aid b -tryRestore :: MonadClientUI m => m (Maybe (State, StateClient, Maybe SessionUI)) +-- | Try to read saved client game state from the file system. +tryRestore :: MonadClientUI m => m (Maybe (StateClient, Maybe SessionUI)) tryRestore = do cops@Kind.COps{corule} <- getsState scops - bench <- getsClient $ sbenchmark . sdebugCli + bench <- getsClient $ sbenchmark . soptions if bench then return Nothing else do side <- getsClient sside - prefix <- getsClient $ ssavePrefixCli . sdebugCli + prefix <- getsClient $ ssavePrefixCli . soptions let fileName = prefix <> Save.saveNameCli cops side res <- liftIO $ Save.restoreGame cops fileName let stdRuleset = Kind.stdRuleset corule diff --git a/Game/LambdaHack/Client/UI/Msg.hs b/Game/LambdaHack/Client/UI/Msg.hs --- a/Game/LambdaHack/Client/UI/Msg.hs +++ b/Game/LambdaHack/Client/UI/Msg.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} --- | Game messages displayed on top of the screen for the player to read. +-- | Game messages displayed on top of the screen for the player to read +-- and then saved to player history. module Game.LambdaHack.Client.UI.Msg ( -- * Msg Msg, toMsg, toPrompt @@ -11,23 +12,28 @@ , History, emptyHistory, addReport, lengthHistory , lastReportOfHistory, replaceLastReportOfHistory , splitReportForHistory, renderHistory +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , UAttrLine, uToAttrLine, attrLineToU + , renderRepetition, renderTimeReport, +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary -import Data.Vector.Binary () +import Data.Binary +import Data.Vector.Binary () import qualified Data.Vector.Unboxed as U -import Data.Word (Word32) -import GHC.Generics (Generic) +import Data.Word (Word32) +import GHC.Generics (Generic) -import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.Overlay import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.RingBuffer as RB -import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Time -- * UAttrLine diff --git a/Game/LambdaHack/Client/UI/MsgM.hs b/Game/LambdaHack/Client/UI/MsgM.hs --- a/Game/LambdaHack/Client/UI/MsgM.hs +++ b/Game/LambdaHack/Client/UI/MsgM.hs @@ -1,6 +1,6 @@ --- | Client monad for interacting with a human through UI. +-- | Monadic operations on game messages. module Game.LambdaHack.Client.UI.MsgM - ( msgAdd, promptAdd, promptAddAttr, recordHistory + ( msgAdd, promptAdd, promptMainKeys, promptAddAttr, recordHistory ) where import Prelude () @@ -11,30 +11,48 @@ import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Client.UI.UIOptions +import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State -- | Add a message to the current report. msgAdd :: MonadClientUI m => Text -> m () msgAdd msg = modifySession $ \sess -> - sess {_sreport = snocReport (_sreport sess) (toMsg $ textToAL msg)} + sess {_sreport = snocReport (sreport sess) (toMsg $ textToAL msg)} -- | Add a prompt to the current report. promptAdd :: MonadClientUI m => Text -> m () promptAdd msg = modifySession $ \sess -> - sess {_sreport = snocReport (_sreport sess) (toPrompt $ textToAL msg)} + sess {_sreport = snocReport (sreport sess) (toPrompt $ textToAL msg)} +-- | Add a prompt with basic keys description. +promptMainKeys :: MonadClientUI m => m () +promptMainKeys = do + saimMode <- getsSession saimMode + UIOptions{uVi, uLaptop} <- getsSession sUIOptions + xhair <- getsSession sxhair + let moveKeys | uVi = "keypad or hjklyubn" + | uLaptop = "keypad or uk8o79jl" + | otherwise = "keypad" + keys | isNothing saimMode = + "Explore with" <+> moveKeys <+> "keys or mouse." + | otherwise = + "Aim" <+> tgtKindDescription xhair + <+> "with" <+> moveKeys <+> "keys or mouse." + promptAdd keys + -- | Add a prompt to the current report. promptAddAttr :: MonadClientUI m => AttrLine -> m () promptAddAttr msg = modifySession $ \sess -> - sess {_sreport = snocReport (_sreport sess) (toPrompt msg)} + sess {_sreport = snocReport (sreport sess) (toPrompt msg)} -- | Store current report in the history and reset report. recordHistory :: MonadClientUI m => m () recordHistory = do time <- getsState stime - SessionUI{_sreport, shistory} <- getSession - unless (nullReport _sreport) $ do - let nhistory = addReport shistory time _sreport + sessionUI <- getSession + unless (nullReport $ sreport sessionUI) $ do + let nhistory = addReport (shistory sessionUI) time (sreport sessionUI) modifySession $ \sess -> sess { _sreport = emptyReport , shistory = nhistory } diff --git a/Game/LambdaHack/Client/UI/Overlay.hs b/Game/LambdaHack/Client/UI/Overlay.hs --- a/Game/LambdaHack/Client/UI/Overlay.hs +++ b/Game/LambdaHack/Client/UI/Overlay.hs @@ -2,42 +2,30 @@ -- | Screen overlays. module Game.LambdaHack.Client.UI.Overlay ( -- * AttrLine - AttrLine, emptyAttrLine, textToAL, fgToAL, stringToAL - , (<+:>), splitAttrLine, itemDesc, glueLines, updateLines + AttrLine, emptyAttrLine, textToAL, fgToAL, stringToAL, (<+:>) -- * Overlay - , Overlay + , Overlay, IntOverlay + , splitAttrLine, glueLines, updateLines -- * Misc , ColorMode(..) - , FrameST, FrameForall(..), writeLine +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , linesAttr, splitAttrPhrase +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Control.Monad.ST.Strict -import qualified Data.EnumMap.Strict as EM import qualified Data.Text as T -import qualified Data.Vector.Generic as G -import qualified Data.Vector.Unboxed as U -import qualified Data.Vector.Unboxed.Mutable as VM -import Data.Word -import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Client.UI.EffectDescription -import Game.LambdaHack.Client.UI.ItemDescription import qualified Game.LambdaHack.Common.Color as Color -import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemStrongest -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Time -import qualified Game.LambdaHack.Content.ItemKind as IK +import Game.LambdaHack.Common.Point -- * AttrLine +-- | Line of colourful text. type AttrLine = [Color.AttrCharW32] emptyAttrLine :: Int -> AttrLine @@ -49,6 +37,7 @@ in ac : l in T.foldr f [] t +-- | Render line of text in the given foreground colour. fgToAL :: Color.Color -> Text -> AttrLine fgToAL !fg !t = let f c l = let !ac = Color.attrChar2ToW32 fg c @@ -64,20 +53,33 @@ (<+:>) l1 [] = l1 (<+:>) l1 l2 = l1 ++ [Color.spaceAttrW32] ++ l2 +-- * Overlay + +-- | A series of screen lines that either fit the width of the screen +-- or are intended for truncation when displayed. The length of overlay +-- may exceed the length of the screen, unlike in @SingleFrame@. +-- An exception is lines generated from animation, which have to fit +-- in either dimension. +type Overlay = [AttrLine] + +-- | Sparse screen overlay representation where only the indicated rows +-- are overlayed and the remaining rows are kept unchanged. +type IntOverlay = [(Int, AttrLine)] + -- | Split a string into lines. Avoids ending the line with a character -- other than whitespace or punctuation. Space characters are removed -- from the start, but never from the end of lines. Newlines are respected. -splitAttrLine :: X -> AttrLine -> [AttrLine] +splitAttrLine :: X -> AttrLine -> Overlay splitAttrLine w l = concatMap (splitAttrPhrase w . dropWhile (== Color.spaceAttrW32)) $ linesAttr l -linesAttr :: AttrLine -> [AttrLine] +linesAttr :: AttrLine -> Overlay linesAttr l | null l = [] | otherwise = h : if null t then [] else linesAttr (tail t) where (h, t) = span (/= Color.retAttrW32) l -splitAttrPhrase :: X -> AttrLine -> [AttrLine] +splitAttrPhrase :: X -> AttrLine -> Overlay splitAttrPhrase w xs | w >= length xs = [xs] -- no problem, everything fits | otherwise = @@ -88,112 +90,14 @@ then pre : splitAttrPhrase w post else reverse ppost : splitAttrPhrase w (reverse ppre ++ post) -itemDesc :: FactionId -> FactionDict -> Int -> CStore -> Time -> ItemFull - -> AttrLine -itemDesc side factionD aHurtMeleeOfOwner store localTime - itemFull@ItemFull{itemBase} = - let (_, unique, name, stats) = - partItemHigh side factionD store localTime itemFull - nstats = makePhrase [name, stats] - IK.ThrowMod{IK.throwVelocity, IK.throwLinger} = strengthToThrow itemBase - speed = speedFromWeight (jweight itemBase) throwVelocity - range = rangeFromSpeedAndLinger speed throwLinger - tspeed | speed < speedLimp = "When thrown, it drops at once." - | speed < speedWalk = "When thrown, it travels only one meter and drops immediately." - | otherwise = - "When thrown, it flies with speed of" - <+> tshow (fromSpeed speed `div` 10) - <> if throwLinger /= 100 - then " m/s and range" <+> tshow range <+> "m." - else " m/s." - (desc, featureSentences, damageAnalysis) = case itemDisco itemFull of - Nothing -> ("This item is as unremarkable as can be.", "", tspeed) - Just ItemDisco{itemKind, itemAspect} -> - let sentences = mapMaybe featureToSentence (IK.ifeature itemKind) - hurtMeleeAspect :: IK.Aspect -> Bool - hurtMeleeAspect IK.AddHurtMelee{} = True - hurtMeleeAspect _ = False - aHurtMeleeOfItem = case itemAspect of - Just aspectRecord -> aHurtMelee aspectRecord - Nothing -> case find hurtMeleeAspect (IK.iaspects itemKind) of - Just (IK.AddHurtMelee d) -> Dice.meanDice d - _ -> 0 - meanDmg = Dice.meanDice (jdamage itemBase) - dmgAn = if meanDmg <= 0 then "" else - let multRaw = aHurtMeleeOfOwner - + if store `elem` [CEqp, COrgan] - then 0 - else aHurtMeleeOfItem - mult = 100 + min 99 (max (-99) multRaw) - minDeltaHP = xM meanDmg `divUp` 100 - rawDeltaHP = fromIntegral mult * minDeltaHP - pmult = 100 + min 99 (max (-99) aHurtMeleeOfItem) - prawDeltaHP = fromIntegral pmult * minDeltaHP - pdeltaHP = modifyDamageBySpeed prawDeltaHP speed - mDeltaHP = modifyDamageBySpeed minDeltaHP speed - in "Against defenceless targets you would inflict around" - -- rounding and non-id items - <+> tshow meanDmg - <> "*" <> tshow mult <> "%" - <> "=" <> show64With2 rawDeltaHP - <+> "melee damage (min" <+> show64With2 minDeltaHP - <> ") and" - <+> tshow meanDmg - <> "*" <> tshow pmult <> "%" - <> "*" <> "speed^2" - <> "/" <> tshow (fromSpeed speedThrust `divUp` 10) <> "^2" - <> "=" <> show64With2 pdeltaHP - <+> "ranged damage (min" <+> show64With2 mDeltaHP - <> ") with it" - <> if Dice.minDice (jdamage itemBase) - == Dice.maxDice (jdamage itemBase) - then "." - else "on average." - in (IK.idesc itemKind, T.intercalate " " sentences, tspeed <+> dmgAn) - eqpSlotSentence = case strengthEqpSlot itemFull of - Just es -> slotToSentence es - Nothing -> "" - weight = jweight itemBase - (scaledWeight, unitWeight) - | weight > 1000 = - (tshow $ fromIntegral weight / (1000 :: Double), "kg") - | otherwise = (tshow weight, "g") - onLevel = "on level" <+> tshow (abs $ fromEnum $ jlid itemBase) <> "." - discoFirst = (if unique then "Discovered" else "First seen") - <+> onLevel - whose fid = gname (factionD EM.! fid) - sourceDesc = - case jfid itemBase of - Just fid | jsymbol itemBase `elem` ['+'] -> - "Caused by" <+> (if fid == side then "us" else whose fid) - <> ". First observed" <+> onLevel - Just fid -> - "Coming from" <+> whose fid - <> "." <+> discoFirst - _ -> discoFirst - colorSymbol = viewItem itemBase - blurb = - " " - <> nstats - <> ":" - <+> desc - <+> (if weight > 0 - then makeSentence ["Weighs", MU.Text scaledWeight <> unitWeight] - else "") - <+> featureSentences - <+> eqpSlotSentence - <+> sourceDesc - <+> damageAnalysis - in colorSymbol : textToAL blurb - -glueLines :: [AttrLine] -> [AttrLine] -> [AttrLine] +glueLines :: Overlay -> Overlay -> Overlay glueLines ov1 ov2 = reverse $ glue (reverse ov1) ov2 where glue [] l = l glue m [] = m glue (mh : mt) (lh : lt) = reverse lt ++ (mh <+:> lh) : mt -- @f@ should not enlarge the line beyond screen width. -updateLines :: Int -> (AttrLine -> AttrLine) -> [AttrLine] -> [AttrLine] +updateLines :: Int -> (AttrLine -> AttrLine) -> Overlay -> Overlay updateLines n f ov = let upd k (l : ls) = if k == 0 then f l : ls @@ -201,34 +105,10 @@ upd _ [] = [] in upd n ov --- blurb about [AttrLine]: --- | A series of screen lines that either fit the width of the screen --- or are intended for truncation when displayed. The length of overlay --- may exceed the length of the screen, unlike in @SingleFrame@. --- An exception is lines generated from animation, which have to fit --- in either dimension. - --- * Overlay - -type Overlay = [(Int, AttrLine)] - -- * Misc -- | Color mode for the display. data ColorMode = ColorFull -- ^ normal, with full colours - | ColorBW -- ^ black+white only + | ColorBW -- ^ black and white only deriving Eq - -type FrameST s = G.Mutable U.Vector s Word32 -> ST s () - -newtype FrameForall = FrameForall {unFrameForall :: forall s. FrameST s} - -writeLine :: Int -> AttrLine -> FrameForall -{-# INLINE writeLine #-} -writeLine offset l = FrameForall $ \v -> do - let writeAt _ [] = return () - writeAt off (ac32 : rest) = do - VM.write v off (Color.attrCharW32 ac32) - writeAt (off + 1) rest - writeAt offset l diff --git a/Game/LambdaHack/Client/UI/OverlayM.hs b/Game/LambdaHack/Client/UI/OverlayM.hs deleted file mode 100644 --- a/Game/LambdaHack/Client/UI/OverlayM.hs +++ /dev/null @@ -1,85 +0,0 @@ --- | A set of Overlay monad operations. -module Game.LambdaHack.Client.UI.OverlayM - ( describeMainKeys, lookAt - ) where - -import Prelude () - -import Game.LambdaHack.Common.Prelude - -import qualified Data.EnumMap.Strict as EM -import qualified Data.Text as T -import qualified NLP.Miniutter.English as MU - -import Game.LambdaHack.Client.CommonM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI.Config -import Game.LambdaHack.Client.UI.ItemDescription -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.State -import qualified Game.LambdaHack.Content.TileKind as TK - -describeMainKeys :: MonadClientUI m => m Text -describeMainKeys = do - saimMode <- getsSession saimMode - Config{configVi, configLaptop} <- getsSession sconfig - xhair <- getsSession sxhair - let moveKeys | configVi = "keypad or hjklyubn" - | configLaptop = "keypad or uk8o79jl" - | otherwise = "keypad" - keys | isNothing saimMode = - "Explore with" <+> moveKeys <+> "keys or mouse." - | otherwise = - "Aim" <+> tgtKindDescription xhair - <+> "with" <+> moveKeys <+> "keys or mouse." - return $! keys - --- | Produces a textual description of the terrain and items at an already --- explored position. Mute for unknown positions. --- The detailed variant is for use in the aiming mode. -lookAt :: MonadClientUI m - => Bool -- ^ detailed? - -> Text -- ^ how to start tile description - -> Bool -- ^ can be seen right now? - -> Point -- ^ position to describe - -> ActorId -- ^ the actor that looks - -> Text -- ^ an extra sentence to print - -> m Text -lookAt detailed tilePrefix canSee pos aid msg = do - Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops - itemToF <- itemToFullClient - b <- getsState $ getActorBody aid - lidV <- viewedLevelUI - lvl <- getLevel lidV - localTime <- getsState $ getLocalTime lidV - subject <- partAidLeader aid - is <- getsState $ getFloorBag lidV pos - side <- getsClient sside - factionD <- getsState sfactionD - let verb = MU.Text $ if | pos == bpos b -> "stand on" - | canSee -> "notice" - | otherwise -> "remember" - let nWs (iid, kit@(k, _)) = - partItemWs side factionD k CGround localTime (itemToF iid kit) - isd = if EM.size is == 0 then "" - else makeSentence [ MU.SubjectVerbSg subject verb - , MU.WWandW $ map nWs $ EM.assocs is] - tile = lvl `at` pos - tileText = TK.tname (okind tile) - tilePart | T.null tilePrefix = MU.Text tileText - | otherwise = MU.AW $ MU.Text tileText - tileDesc = [MU.Text tilePrefix, tilePart] - if | detailed -> - return $! makeSentence tileDesc <+> msg <+> isd - | otherwise -> - return $! msg <+> isd diff --git a/Game/LambdaHack/Client/UI/RunM.hs b/Game/LambdaHack/Client/UI/RunM.hs --- a/Game/LambdaHack/Client/UI/RunM.hs +++ b/Game/LambdaHack/Client/UI/RunM.hs @@ -12,6 +12,10 @@ -- heard, solid tiles and actors in the way. module Game.LambdaHack.Client.UI.RunM ( continueRun +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , continueRunDir, enterableDir, tryTurning, checkAndRun +#endif ) where import Prelude () @@ -19,24 +23,24 @@ import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM -import Data.Function +import Data.Function -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.Msg -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.Request +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI.MonadClientUI +import Game.LambdaHack.Client.UI.Msg +import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.TileKind as TK -- | Continue running in the given direction. @@ -107,7 +111,7 @@ RunParams{ runLeader , runMembers = aid : _ , runInitial } -> do - report <- getsSession _sreport + report <- getsSession sreport let boringMsgs = map stringToAL [ "You hear a distant" , "reveals that the" diff --git a/Game/LambdaHack/Client/UI/SessionUI.hs b/Game/LambdaHack/Client/UI/SessionUI.hs --- a/Game/LambdaHack/Client/UI/SessionUI.hs +++ b/Game/LambdaHack/Client/UI/SessionUI.hs @@ -1,41 +1,40 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | The client UI session state. module Game.LambdaHack.Client.UI.SessionUI - ( SessionUI(..), emptySessionUI - , AimMode(..), RunParams(..), LastRecord, KeysHintMode(..) - , toggleMarkVision, toggleMarkSmell, getActorUI + ( SessionUI(..), AimMode(..), RunParams(..), LastRecord(..), KeysHintMode(..) + , sreport, emptySessionUI, toggleMarkVision, toggleMarkSmell, getActorUI ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M -import Data.Time.Clock.POSIX +import Data.Time.Clock.POSIX -import Game.LambdaHack.Client.UI.ActorUI -import Game.LambdaHack.Client.UI.Config -import Game.LambdaHack.Client.UI.Frontend -import Game.LambdaHack.Client.UI.ItemSlot +import Game.LambdaHack.Client.UI.ActorUI +import Game.LambdaHack.Client.UI.Frontend +import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.KeyBindings -import Game.LambdaHack.Client.UI.Msg -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Client.UI.KeyBindings +import Game.LambdaHack.Client.UI.Msg +import Game.LambdaHack.Client.UI.UIOptions +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector -- | The information that is used across a client playing session, -- including many consecutive games in a single session. -- Some of it is saved, some is reset when a new playing session starts. --- An important component is a frontend session. +-- An important component is the frontend session. data SessionUI = SessionUI { sxhair :: Target -- ^ the common xhair , sactorUI :: ActorDictUI -- ^ assigned actor UI presentations @@ -44,7 +43,7 @@ , slastItemMove :: Maybe (CStore, CStore) -- ^ last item move stores , schanF :: ChanFrontend -- ^ connection with the frontend , sbinding :: Binding -- ^ binding of keys to commands - , sconfig :: Config + , sUIOptions :: UIOptions -- ^ UI options as set by the player , saimMode :: Maybe AimMode -- ^ aiming mode , sxhairMoused :: Bool -- ^ last mouse aiming not vacuus , sitemSel :: Maybe (CStore, ItemId) -- ^ selected item, if any @@ -64,7 +63,7 @@ , smarkSmell :: Bool -- ^ mark smell, if the leader can smell , smenuIxMap :: M.Map String Int -- ^ indices of last used menu items - , sdisplayNeeded :: Bool -- ^ something to display on current level + , sdisplayNeeded :: Bool -- ^ current level needs displaying , skeysHintMode :: KeysHintMode -- ^ how to show keys hints when no messages , sstart :: POSIXTime -- ^ this session start time , sgstart :: POSIXTime -- ^ this game start time @@ -88,10 +87,12 @@ } deriving (Show) -type LastRecord = ( [K.KM] -- accumulated keys of the current command - , [K.KM] -- keys of the rest of the recorded command batch - , Int -- commands left to record for this batch - ) +-- | State of last recorded and currently being recorded key sequences. +data LastRecord = LastRecord + { currentKeys :: [K.KM] -- ^ accumulated keys of the current command + , previousKeys :: [K.KM] -- ^ keys of the rest of the recorded command batch + , freeSpace :: Int -- ^ space left for commands to record in this batch + } data KeysHintMode = KeysHintBlocked @@ -99,9 +100,11 @@ | KeysHintPresent deriving (Eq, Enum, Bounded) --- | Initial empty game client state. -emptySessionUI :: Config -> SessionUI -emptySessionUI sconfig = +sreport :: SessionUI -> Report +sreport = _sreport + +emptySessionUI :: UIOptions -> SessionUI +emptySessionUI sUIOptions = SessionUI { sxhair = TVector $ Vector 0 0 , sactorUI = EM.empty @@ -111,7 +114,7 @@ , schanF = ChanFrontend $ const $ error $ "emptySessionUI: ChanFrontend" `showFailure` () , sbinding = Binding M.empty [] M.empty - , sconfig + , sUIOptions , saimMode = Nothing , sxhairMoused = True , sitemSel = Nothing @@ -120,7 +123,7 @@ , _sreport = emptyReport , shistory = emptyHistory 0 , spointer = originPoint - , slastRecord = ([], [], 0) + , slastRecord = LastRecord [] [] 0 , slastPlay = [] , slastLost = ES.empty , swaitTimes = 0 @@ -153,7 +156,7 @@ put sactorUI put sslots put slastSlot - put sconfig + put sUIOptions put saimMode put sitemSel put sselected @@ -168,7 +171,7 @@ sactorUI <- get sslots <- get slastSlot <- get - sconfig <- get -- is overwritten ASAP, but useful for, e.g., crash debug + sUIOptions <- get -- is overwritten ASAP, but useful for, e.g., crash debug saimMode <- get sitemSel <- get sselected <- get @@ -184,7 +187,7 @@ sbinding = Binding M.empty [] M.empty sxhairMoused = True spointer = originPoint - slastRecord = ([], [], 0) + slastRecord = LastRecord [] [] 0 slastPlay = [] slastLost = ES.empty swaitTimes = 0 diff --git a/Game/LambdaHack/Client/UI/Slideshow.hs b/Game/LambdaHack/Client/UI/Slideshow.hs --- a/Game/LambdaHack/Client/UI/Slideshow.hs +++ b/Game/LambdaHack/Client/UI/Slideshow.hs @@ -3,25 +3,33 @@ ( KYX, OKX, Slideshow(slideshow) , emptySlideshow, unsnoc, toSlideshow, menuToSlideshow , wrapOKX, splitOverlay, splitOKX +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , moreMsg, endMsg, keysOKX +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Game.LambdaHack.Client.UI.ItemSlot +import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.Msg -import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.Msg +import Game.LambdaHack.Client.UI.Overlay import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Point +-- | A key or an item slot label at a given position on the screen. type KYX = (Either [K.KM] SlotChar, (Y, X, X)) -type OKX = ([AttrLine], [KYX]) +-- | An Overlay of text with an associated list of keys or slots +-- that activated when the specified screen position is pointed at. +-- The list should be sorted wrt rows and then columns. +type OKX = (Overlay, [KYX]) --- May be empty, but both of each @OKX@ list have to be nonempty. --- Guaranteed by construction. +-- | A list of active screenfulls to be shown one after another. +-- Each screenful has an independent numbering of rows and columns. newtype Slideshow = Slideshow {slideshow :: [OKX]} deriving (Show, Eq) diff --git a/Game/LambdaHack/Client/UI/SlideshowM.hs b/Game/LambdaHack/Client/UI/SlideshowM.hs --- a/Game/LambdaHack/Client/UI/SlideshowM.hs +++ b/Game/LambdaHack/Client/UI/SlideshowM.hs @@ -1,4 +1,4 @@ --- | A set of Slideshow monad operations. +-- | Monadic operations on slideshows and related data. module Game.LambdaHack.Client.UI.SlideshowM ( overlayToSlideshow, reportToSlideshow, reportToSlideshowKeep , displaySpaceEsc, displayMore, displayMoreKeep, displayYesNo, getConfirms @@ -9,18 +9,18 @@ import Game.LambdaHack.Common.Prelude -import Game.LambdaHack.Client.UI.FrameM -import Game.LambdaHack.Client.UI.ItemSlot +import Game.LambdaHack.Client.UI.FrameM +import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.MsgM -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Client.UI.Slideshow +import Game.LambdaHack.Client.UI.MonadClientUI +import Game.LambdaHack.Client.UI.MsgM +import Game.LambdaHack.Client.UI.Overlay +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Client.UI.Slideshow import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point -- | Add current report to the overlay, split the result and produce, -- possibly, many slides. @@ -89,7 +89,11 @@ (ekm, _) <- displayChoiceScreen dm False 0 slides extraKeys return $! either id (error $ "" `showFailure` ekm) ekm --- This is the only source of menus and so, effectively, UI modes. +-- | Display a, potentially, multi-screen menu and return the chosen +-- key or item slot label (and the index in the whole menu so that the cursor +-- can again be placed at that spot next time menu is displayed). +-- +-- This function is the only source of menus and so, effectively, UI modes. displayChoiceScreen :: forall m . MonadClientUI m => ColorMode -> Bool -> Int -> Slideshow -> [K.KM] -> m (Either K.KM SlotChar, Int) @@ -191,7 +195,8 @@ page (max 0 (pointer - ixOnPage - 1)) _ | K.key ikm `elem` [K.PgDn, K.WheelSouth] -> page (min maxIx (pointer + pageLen - ixOnPage)) - K.Space -> ignoreKey + K.Space -> if pointer == maxIx then page 0 + else page maxIx _ -> error $ "unknown key" `showFailure` ikm pkm <- promptGetKey dm ov1 sfBlank legalKeys interpretKey pkm diff --git a/Game/LambdaHack/Client/UI/UIOptions.hs b/Game/LambdaHack/Client/UI/UIOptions.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Client/UI/UIOptions.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | UI client options. +module Game.LambdaHack.Client.UI.UIOptions + ( UIOptions(..), mkUIOptions, applyUIOptions +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , parseConfig +#endif + ) where + +import Prelude () + +import Game.LambdaHack.Common.Prelude + +import Control.DeepSeq +import Data.Binary +import qualified Data.Ini as Ini +import qualified Data.Ini.Reader as Ini +import qualified Data.Ini.Types as Ini +import qualified Data.Map.Strict as M +import Game.LambdaHack.Client.ClientOptions +import GHC.Generics (Generic) +import System.FilePath +import Text.Read + +import Game.LambdaHack.Client.UI.HumanCmd +import qualified Game.LambdaHack.Client.UI.Key as K +import Game.LambdaHack.Common.File +import qualified Game.LambdaHack.Common.Kind as Kind +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Content.RuleKind + +-- | Options that affect the UI of the client. +data UIOptions = UIOptions + { -- commands + uCommands :: [(K.KM, CmdTriple)] + -- hero names + , uHeroNames :: [(Int, (Text, Text))] + -- ui + , uVi :: Bool -- ^ the option for Vi keys takes precendence + , uLaptop :: Bool -- ^ because the laptop keys are the default + , uGtkFontFamily :: Text + , uSdlFontFile :: Text + , uSdlTtfSizeAdd :: Int + , uSdlFonSizeAdd :: Int + , uFontSize :: Int + , uColorIsBold :: Bool + , uHistoryMax :: Int + , uMaxFps :: Int + , uNoAnim :: Bool + , uRunStopMsgs :: Bool + , uCmdline :: [String] -- ^ Hardwired commandline arguments to process. + } + deriving (Show, Generic) + +instance NFData UIOptions + +instance Binary UIOptions + +parseConfig :: Ini.Config -> UIOptions +parseConfig cfg = + let uCommands = + let mkCommand (ident, keydef) = + case stripPrefix "Cmd_" ident of + Just _ -> + let (key, def) = read keydef + in (K.mkKM key, def :: CmdTriple) + Nothing -> error $ "wrong macro id" `showFailure` ident + section = Ini.allItems "extra_commands" cfg + in map mkCommand section + uHeroNames = + let toNumber (ident, nameAndPronoun) = + case stripPrefix "HeroName_" ident of + Just n -> (read n, read nameAndPronoun) + Nothing -> error $ "wrong hero name id" `showFailure` ident + section = Ini.allItems "hero_names" cfg + in map toNumber section + getOption :: forall a. Read a => String -> a + getOption optionName = + let lookupFail :: forall b. String -> b + lookupFail err = + error $ "config file access failed" + `showFailure` (err, optionName, cfg) + s = fromMaybe (lookupFail "") $ Ini.getOption "ui" optionName cfg + in either lookupFail id $ readEither s + uVi = getOption "movementViKeys_hjklyubn" + -- The option for Vi keys takes precendence, + -- because the laptop keys are the default. + uLaptop = not uVi && getOption "movementLaptopKeys_uk8o79jl" + uGtkFontFamily = getOption "gtkFontFamily" + uSdlFontFile = getOption "sdlFontFile" + uSdlTtfSizeAdd = getOption "sdlTtfSizeAdd" + uSdlFonSizeAdd = getOption "sdlFonSizeAdd" + uFontSize = getOption "fontSize" + uColorIsBold = getOption "colorIsBold" + uHistoryMax = getOption "historyMax" + uMaxFps = max 1 $ getOption "maxFps" + uNoAnim = getOption "noAnim" + uRunStopMsgs = getOption "runStopMsgs" + uCmdline = words $ getOption "overrideCmdline" + in UIOptions{..} + +-- | Read and parse UI config file. +mkUIOptions :: Kind.COps -> Bool -> IO UIOptions +mkUIOptions Kind.COps{corule} benchmark = do + let stdRuleset = Kind.stdRuleset corule + cfgUIName = rcfgUIName stdRuleset + sUIDefault = rcfgUIDefault stdRuleset + cfgUIDefault = either (error . ("" `showFailure`)) id + $ Ini.parse sUIDefault + dataDir <- appDataDir + let userPath = dataDir cfgUIName + cfgUser <- if benchmark then return Ini.emptyConfig else do + cpExists <- doesFileExist userPath + if not cpExists + then return Ini.emptyConfig + else do + sUser <- readFile userPath + return $! either (error . ("" `showFailure`)) id $ Ini.parse sUser + let cfgUI = M.unionWith M.union cfgUser cfgUIDefault -- user cfg preferred + conf = parseConfig cfgUI + -- Catch syntax errors in complex expressions ASAP, + return $! deepseq conf conf + +-- | Modify client options with UI options. +applyUIOptions :: Kind.COps -> UIOptions -> ClientOptions -> ClientOptions +applyUIOptions Kind.COps{corule} uioptions soptions = + let stdRuleset = Kind.stdRuleset corule + in (\opts -> opts {sgtkFontFamily = + sgtkFontFamily opts `mplus` Just (uGtkFontFamily uioptions)}) . + (\opts -> opts {sdlFontFile = + sdlFontFile opts `mplus` Just (uSdlFontFile uioptions)}) . + (\opts -> opts {sdlTtfSizeAdd = + sdlTtfSizeAdd opts `mplus` Just (uSdlTtfSizeAdd uioptions)}) . + (\opts -> opts {sdlFonSizeAdd = + sdlFonSizeAdd opts `mplus` Just (uSdlFonSizeAdd uioptions)}) . + (\opts -> opts {sfontSize = + sfontSize opts `mplus` Just (uFontSize uioptions)}) . + (\opts -> opts {scolorIsBold = + scolorIsBold opts `mplus` Just (uColorIsBold uioptions)}) . + (\opts -> opts {smaxFps = + smaxFps opts `mplus` Just (uMaxFps uioptions)}) . + (\opts -> opts {snoAnim = + snoAnim opts `mplus` Just (uNoAnim uioptions)}) . + (\opts -> opts {stitle = + stitle opts `mplus` Just (rtitle stdRuleset)}) . + (\opts -> opts {sfontDir = + sfontDir opts `mplus` Just (rfontDir stdRuleset)}) + $ soptions diff --git a/Game/LambdaHack/Common/Ability.hs b/Game/LambdaHack/Common/Ability.hs --- a/Game/LambdaHack/Common/Ability.hs +++ b/Game/LambdaHack/Common/Ability.hs @@ -10,11 +10,11 @@ import Game.LambdaHack.Common.Prelude -import Control.DeepSeq -import Data.Binary +import Control.DeepSeq +import Data.Binary import qualified Data.EnumMap.Strict as EM -import Data.Hashable (Hashable) -import GHC.Generics (Generic) +import Data.Hashable (Hashable) +import GHC.Generics (Generic) import Game.LambdaHack.Common.Misc @@ -38,16 +38,6 @@ -- It's also easier to code and maintain. type Skills = EM.EnumMap Ability Int -tacticSkills :: Tactic -> Skills -tacticSkills TExplore = zeroSkills -tacticSkills TFollow = zeroSkills -tacticSkills TFollowNoItems = ignoreItems -tacticSkills TMeleeAndRanged = meleeAndRanged -tacticSkills TMeleeAdjacent = meleeAdjacent -tacticSkills TBlock = blockOnly -tacticSkills TRoam = zeroSkills -tacticSkills TPatrol = zeroSkills - zeroSkills :: Skills zeroSkills = EM.empty @@ -59,6 +49,16 @@ scaleSkills :: Int -> Skills -> Skills scaleSkills n = EM.map (n *) + +tacticSkills :: Tactic -> Skills +tacticSkills TExplore = zeroSkills +tacticSkills TFollow = zeroSkills +tacticSkills TFollowNoItems = ignoreItems +tacticSkills TMeleeAndRanged = meleeAndRanged +tacticSkills TMeleeAdjacent = meleeAdjacent +tacticSkills TBlock = blockOnly +tacticSkills TRoam = zeroSkills +tacticSkills TPatrol = zeroSkills minusTen, blockOnly, meleeAdjacent, meleeAndRanged, ignoreItems :: Skills diff --git a/Game/LambdaHack/Common/Actor.hs b/Game/LambdaHack/Common/Actor.hs --- a/Game/LambdaHack/Common/Actor.hs +++ b/Game/LambdaHack/Common/Actor.hs @@ -1,44 +1,44 @@ {-# LANGUAGE DeriveGeneric #-} --- | Actors in the game: heroes, monsters, etc. No operation in this module --- involves the 'State' or 'Action' type. +-- | Actors in the game: heroes, monsters, etc. module Game.LambdaHack.Common.Actor - ( -- * Actor identifiers and related operations - ActorId, monsterGenChance - -- * The@ Acto@r type + ( -- * Actor identifiers + ActorId + -- * The@ Acto@r type, its components and operations on them , Actor(..), ResDelta(..), ActorAspect , deltaSerious, deltaMild, actorCanMelee - , bspeed, actorTemplate, braced, waitedLastTurn, actorDying + , bspeed, braced, actorTemplate, waitedLastTurn, actorDying , actorTrunkIsBlast, hpTooLow, calmEnough, hpEnough + , checkAdjacent, eqpOverfull, eqpFreeN -- * Assorted - , ActorDict, smellTimeout, checkAdjacent - , eqpOverfull, eqpFreeN + , ActorDict, monsterGenChance, smellTimeout ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM -import Data.Int (Int64) -import Data.Ratio -import GHC.Generics (Generic) +import Data.Int (Int64) +import Data.Ratio +import GHC.Generics (Generic) import qualified Game.LambdaHack.Common.Ability as Ability -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector -- | Actor properties that are changing throughout the game. --- If they are dublets of properties from @ActorKind@, --- they are usually modified temporarily, but tend to return --- to the original value from @ActorKind@ over time. E.g., HP. +-- If they appear dublets of properties of actor kinds, e.g. HP, +-- they may be results of casting the dice specified in their respective +-- actor kind and/or may be modified temporarily, but return +-- to the original value from their respective kind over time. data Actor = Actor { -- The trunk of the actor's body (present also in @borgan@ or @beqp@) - btrunk :: ItemId + btrunk :: ItemId -- ^ the trunk organ of the actor's body -- Resources , bhp :: Int64 -- ^ current hit points * 1M @@ -48,11 +48,10 @@ -- Location , bpos :: Point -- ^ current position - , boldpos :: (Maybe Point) - -- ^ previous position, if any + , boldpos :: Maybe Point -- ^ previous position, if any , blid :: LevelId -- ^ current level , bfid :: FactionId -- ^ faction the actor currently belongs to - , btrajectory :: (Maybe ([Vector], Speed)) + , btrajectory :: Maybe ([Vector], Speed) -- ^ trajectory the actor must -- travel and his travel speed @@ -82,6 +81,9 @@ type ActorAspect = EM.EnumMap ActorId AspectRecord +-- | All actors on the level, indexed by actor identifier. +type ActorDict = EM.EnumMap ActorId Actor + deltaSerious :: ResDelta -> Bool deltaSerious ResDelta{..} = fst resCurrentTurn < 0 && fst resCurrentTurn /= minusM @@ -99,25 +101,16 @@ canMelee = EM.findWithDefault 0 Ability.AbMelee actorMaxSk > 0 in condUsableWeapon && canMelee --- | Chance that a new monster is generated. Currently depends on the --- number of monsters already present, and on the level. In the future, --- the strength of the character and the strength of the monsters present --- could further influence the chance, and the chance could also affect --- which monster is generated. How many and which monsters are generated --- will also depend on the cave kind used to build the level. -monsterGenChance :: AbsDepth -> AbsDepth -> Int -> Int -> Rnd Bool -monsterGenChance _ _ _ 0 = return False -monsterGenChance (AbsDepth n) (AbsDepth totalDepth) lvlSpawned actorCoeff = - assert (totalDepth > 0 && n > 0) - -- Mimics @castDice@. On level 5/10, first 6 monsters appear fast. - $ let scaledDepth = n * 10 `div` totalDepth - -- Heroes have to endure two lvl-sized waves of spawners for each level. - numSpawnedCoeff = lvlSpawned `div` 2 - in chance $ 1%(fromIntegral - ((actorCoeff * (numSpawnedCoeff - scaledDepth)) - `max` 1)) -- monsters up to level depth spawned at once +bspeed :: Actor -> AspectRecord -> Speed +bspeed !b AspectRecord{aSpeed} = + case btrajectory b of + Nothing -> toSpeed aSpeed + Just (_, speed) -> speed --- | A template for a new actor. +-- | Whether an actor is braced for combat this clip. +braced :: Actor -> Bool +braced = bwait + actorTemplate :: ItemId -> Int64 -> Int64 -> Point -> LevelId -> FactionId -> Actor actorTemplate btrunk bhp bcalm bpos blid bfid = @@ -133,17 +126,6 @@ bproj = False in Actor{..} -bspeed :: Actor -> AspectRecord -> Speed -bspeed !b AspectRecord{aSpeed} = - case btrajectory b of - Nothing -> toSpeed aSpeed - Just (_, speed) -> speed - --- | Whether an actor is braced for combat this clip. -braced :: Actor -> Bool -braced = bwait - --- | The actor waited last turn. waitedLastTurn :: Actor -> Bool waitedLastTurn = bwait @@ -171,13 +153,6 @@ let hpMax = max 1 aMaxHP in xM hpMax <= 2 * bhp b && bhp b > xM 1 --- | How long until an actor's smell vanishes from a tile. -smellTimeout :: Delta Time -smellTimeout = timeDeltaScale (Delta timeTurn) 100 - --- | All actors on the level, indexed by actor identifier. -type ActorDict = EM.EnumMap ActorId Actor - checkAdjacent :: Actor -> Actor -> Bool checkAdjacent sb tb = blid sb == blid tb && adjacent (bpos sb) (bpos tb) @@ -190,3 +165,25 @@ eqpFreeN b = let size = sum $ map fst $ EM.elems $ beqp b in assert (size <= 10 `blame` (b, size)) $ 10 - size + +-- | Chance that a new monster is generated. Currently depends on the +-- number of monsters already present, and on the level. In the future, +-- the strength of the character and the strength of the monsters present +-- could further influence the chance, and the chance could also affect +-- which monster is generated. How many and which monsters are generated +-- will also depend on the cave kind used to build the level. +monsterGenChance :: AbsDepth -> AbsDepth -> Int -> Int -> Rnd Bool +monsterGenChance _ _ _ 0 = return False +monsterGenChance (AbsDepth n) (AbsDepth totalDepth) lvlSpawned actorCoeff = + assert (totalDepth > 0 && n > 0) + -- Mimics @castDice@. On level 5/10, first 6 monsters appear fast. + $ let scaledDepth = n * 10 `div` totalDepth + -- Heroes have to endure two lvl-sized waves of spawners for each level. + numSpawnedCoeff = lvlSpawned `div` 2 + in chance $ 1%fromIntegral + ((actorCoeff * (numSpawnedCoeff - scaledDepth)) + `max` 1) -- monsters up to level depth spawned at once + +-- | How long until an actor's smell vanishes from a tile. +smellTimeout :: Delta Time +smellTimeout = timeDeltaScale (Delta timeTurn) 100 diff --git a/Game/LambdaHack/Common/ActorState.hs b/Game/LambdaHack/Common/ActorState.hs --- a/Game/LambdaHack/Common/ActorState.hs +++ b/Game/LambdaHack/Common/ActorState.hs @@ -1,19 +1,20 @@ {-# LANGUAGE TupleSections #-} --- | Operations on the 'Actor' type that need the 'State' type, +-- | Operations on the 'Actor' type, and related, that need the 'State' type, -- but not our custom monad types. module Game.LambdaHack.Common.ActorState ( fidActorNotProjAssocs, actorAssocs, actorRegularAssocs , warActorRegularList, friendlyActorRegularList, fidActorRegularIds - , bagAssocs, bagAssocsK, calculateTotal - , mergeItemQuant, sharedEqp, sharedAllOwnedFid, findIid + , bagAssocs, bagAssocsK, posToAidsLvl, posToAids, posToAssocs + , nearbyFreePoints, calculateTotal, mergeItemQuant + , sharedInv, sharedEqp, sharedAllOwned, sharedAllOwnedFid, findIid + , getActorBody, getActorAspect, getCarriedAssocs, getCarriedIidCStore , getContainerBag, getFloorBag, getEmbedBag, getBodyStoreBag - , mapActorItems_, getActorAssocs - , nearbyFreePoints, getCarriedAssocs, getCarriedIidCStore - , posToAidsLvl, posToAids, posToAssocs - , getItemBody, memActor, getActorBody, getLocalTime, regenCalmDelta - , actorInAmbient, canDeAmbientList, actorSkills, dispEnemy, fullAssocs - , storeFromC, lidFromC, posFromC, aidFromC, isEscape, isStair - , anyFoeAdj, actorAdjacentAssocs, armorHurtBonus + , mapActorItems_, getActorAssocs, getActorAssocsK + , memActor, getLocalTime, regenCalmDelta + , actorInAmbient, canDeAmbientList, actorSkills, dispEnemy + , itemToFull, fullAssocs, storeFromC, aidFromC, lidFromC, posFromC + , isEscape, isStair, anyFoeAdj, actorAdjacentAssocs + , armorHurtBonus, inMelee ) where import Prelude () @@ -21,23 +22,23 @@ import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM -import Data.Int (Int64) -import GHC.Exts (inline) +import Data.Int (Int64) +import GHC.Exts (inline) import qualified Game.LambdaHack.Common.Ability as Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.TileKind (TileKind) +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.TileKind (TileKind) fidActorNotProjAssocs :: FactionId -> State -> [(ActorId, Actor)] fidActorNotProjAssocs fid s = @@ -72,11 +73,6 @@ fidActorRegularIds fid lid s = map fst $ actorRegularAssocs (== fid) lid s -getItemBody :: ItemId -> State -> Item -getItemBody iid s = - let assFail = error $ "item body not found" `showFailure` (iid, s) - in EM.findWithDefault assFail iid $ sitemD s - bagAssocs :: State -> ItemBag -> [(ItemId, Item)] bagAssocs s bag = let iidItem iid = (iid, getItemBody iid s) @@ -160,6 +156,10 @@ {-# INLINE getActorBody #-} getActorBody aid s = sactorD s EM.! aid +getActorAspect :: ActorId -> State -> AspectRecord +{-# INLINE getActorAspect #-} +getActorAspect aid s = sactorAspect s EM.! aid + getCarriedAssocs :: Actor -> State -> [(ItemId, Item)] getCarriedAssocs b s = -- The trunk is important for a case of spotting a caught projectile @@ -204,8 +204,7 @@ CSha -> gsha $ sfactionD s EM.! bfid b mapActorItems_ :: Monad m - => (CStore -> ItemId -> ItemQuant -> m a) -> Actor - -> State + => (CStore -> ItemId -> ItemQuant -> m a) -> Actor -> State -> m () mapActorItems_ f b s = do let notProcessed = [CGround] @@ -269,10 +268,10 @@ then filter posDeAmbient (vicinityUnsafe $ bpos b) else [] -actorSkills :: Maybe ActorId -> ActorId -> AspectRecord -> State - -> Ability.Skills -actorSkills mleader aid ar s = +actorSkills :: Maybe ActorId -> ActorId -> State -> Ability.Skills +actorSkills mleader aid s = let body = getActorBody aid s + ar = getActorAspect aid s player = gplayer . (EM.! bfid body) . sfactionD $ s skillsFromTactic = Ability.tacticSkills $ ftactic player factionSkills @@ -301,13 +300,16 @@ || EM.findWithDefault 0 Ability.AbMove actorMaxSk <= 0 || hasSupport sb && hasSupport tb) -- solo actors are flexible -fullAssocs :: Kind.COps -> DiscoveryKind -> DiscoveryAspect - -> ActorId -> [CStore] -> State - -> [(ItemId, ItemFull)] -fullAssocs cops disco discoAspect aid cstores s = +itemToFull :: State -> ItemId -> ItemQuant -> ItemFull +itemToFull s iid = + itemToFull6 (scops s) (sdiscoKind s) (sdiscoAspect s) iid (getItemBody iid s) + +fullAssocs :: ActorId -> [CStore] -> State -> [(ItemId, ItemFull)] +fullAssocs aid cstores s = let allAssocs = concatMap (\cstore -> getActorAssocsK aid cstore s) cstores iToFull (iid, (item, kit)) = - (iid, itemToFull cops disco discoAspect iid item kit) + (iid, itemToFull6 (scops s) (sdiscoKind s) (sdiscoAspect s) + iid item kit) in map iToFull allAssocs storeFromC :: Container -> CStore @@ -379,15 +381,31 @@ g !aid = (aid, getActorBody aid s) in map g $ concatMap f moves -armorHurtBonus :: ActorAspect -> ActorId -> ActorId -> State -> Int -armorHurtBonus actorAspect source target s = +armorHurtBonus :: ActorId -> ActorId -> State -> Int +armorHurtBonus source target s = let sb = getActorBody source s tb = getActorBody target s trim200 n = min 200 $ max (-200) n block200 b n = min 200 $ max (-200) $ n + if braced tb then b else 0 - sar = actorAspect EM.! source - tar = actorAspect EM.! target + sar = sactorAspect s EM.! source + tar = sactorAspect s EM.! target itemBonus = trim200 (aHurtMelee sar) - if bproj sb then block200 25 (aArmorRanged tar) else block200 50 (aArmorMelee tar) in 100 + min 99 (max (-99) itemBonus) -- at least 1% of damage gets through + +inMelee :: Actor -> State -> Bool +inMelee bodyOur s = + let fact = sfactionD s EM.! bfid bodyOur + f !b = blid b == blid bodyOur && isAtWar fact (bfid b) && bhp b > 0 + -- We assume foes are less numerous, because usually they are heroes, + -- and so we compute them once and use many times. + -- For the same reason @anyFoeAdj@ would not speed up this computation + -- in normal gameplay (as opposed to AI vs AI benchmarks). + allFoes = filter f $ EM.elems $ sactorD s + in any (\body -> + bfid bodyOur == bfid body + && blid bodyOur == blid body + && not (bproj body) + && bhp body > 0 + && any (\b -> adjacent (bpos b) (bpos body)) allFoes) $ sactorD s diff --git a/Game/LambdaHack/Common/ClientOptions.hs b/Game/LambdaHack/Common/ClientOptions.hs deleted file mode 100644 --- a/Game/LambdaHack/Common/ClientOptions.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} --- | Screen frames and animations. -module Game.LambdaHack.Common.ClientOptions - ( DebugModeCli(..), defDebugModeCli - ) where - -import Prelude () - -import Game.LambdaHack.Common.Prelude - -import Data.Binary -import GHC.Generics (Generic) - -data DebugModeCli = DebugModeCli - { sgtkFontFamily :: Maybe Text - -- ^ Font family to use for the GTK main game window. - , sdlFontFile :: Maybe Text - -- ^ Font file to use for the SDL2 main game window. - , sdlTtfSizeAdd :: Maybe Int - -- ^ Pixels to add to map cells on top of scalable font max glyph height. - , sdlFonSizeAdd :: Maybe Int - -- ^ Pixels to add to map cells on top of .fon font max glyph height. - , sfontSize :: Maybe Int - -- ^ Font size to use for the main game window. - , scolorIsBold :: Maybe Bool - -- ^ Whether to use bold attribute for colorful characters. - , smaxFps :: Maybe Int - -- ^ Maximal frames per second. - -- This is better low and fixed, to avoid jerkiness and delays - -- that tell the player there are many intelligent enemies on the level. - -- That's better than scaling AI sofistication down based - -- on the FPS setting and machine speed. - , sdisableAutoYes :: Bool - -- ^ Never auto-answer all prompts, even if under AI control. - , snoAnim :: Maybe Bool - -- ^ Don't show any animations. - , snewGameCli :: Bool - -- ^ Start a new game, overwriting the save file. - , sbenchmark :: Bool - -- ^ Don't create directories and files and show time stats. - , stitle :: Maybe Text - , sfontDir :: Maybe FilePath - , ssavePrefixCli :: String - -- ^ Prefix of the save game file name. - , sfrontendTeletype :: Bool - -- ^ Whether to use the stdout/stdin frontend. - , sfrontendNull :: Bool - -- ^ Whether to use null (no input/output) frontend. - , sfrontendLazy :: Bool - -- ^ Whether to use lazy (output not even calculated) frontend. - , sdbgMsgCli :: Bool - -- ^ Show clients' internal debug messages. - , sstopAfterSeconds :: Maybe Int - , sstopAfterFrames :: Maybe Int - } - deriving (Show, Eq, Generic) - -instance Binary DebugModeCli - -defDebugModeCli :: DebugModeCli -defDebugModeCli = DebugModeCli - { sgtkFontFamily = Nothing - , sdlFontFile = Nothing - , sdlTtfSizeAdd = Nothing - , sdlFonSizeAdd = Nothing - , sfontSize = Nothing - , scolorIsBold = Nothing - , smaxFps = Nothing - , sdisableAutoYes = False - , snoAnim = Nothing - , snewGameCli = False - , sbenchmark = False - , stitle = Nothing - , sfontDir = Nothing - , ssavePrefixCli = "" - , sfrontendTeletype = False - , sfrontendNull = False - , sfrontendLazy = False - , sdbgMsgCli = False - , sstopAfterSeconds = Nothing - , sstopAfterFrames = Nothing - } diff --git a/Game/LambdaHack/Common/Color.hs b/Game/LambdaHack/Common/Color.hs --- a/Game/LambdaHack/Common/Color.hs +++ b/Game/LambdaHack/Common/Color.hs @@ -2,32 +2,31 @@ -- | Colours and text attributes. module Game.LambdaHack.Common.Color ( -- * Colours - Color(..), defFG, isBright, darkCol, brightCol, stdCol - , colorToRGB - , Highlight (..) - -- * Text attributes and the screen - , Attr(..), defAttr - , AttrChar(..) - , AttrCharW32(..) + Color(..) + , defFG, isBright, darkCol, brightCol, stdCol, colorToRGB + -- * Complete text attributes + , Highlight (..), Attr(..) + , defAttr + -- * Characters with attributes + , AttrChar(..), AttrCharW32(..) , attrCharToW32, attrCharFromW32 , fgFromW32, bgFromW32, charFromW32, attrFromW32, attrEnumFromW32 - , spaceAttrW32, retAttrW32 - , attrChar2ToW32, attrChar1ToW32 + , spaceAttrW32, retAttrW32, attrChar2ToW32, attrChar1ToW32 ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary -import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) +import Data.Binary +import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) import qualified Data.Char as Char -import Data.Hashable (Hashable) -import Data.Word (Word32) -import GHC.Exts (Int (I#)) -import GHC.Generics (Generic) -import GHC.Prim (int2Word#) -import GHC.Word (Word32 (W32#)) +import Data.Hashable (Hashable) +import Data.Word (Word32) +import GHC.Exts (Int (I#)) +import GHC.Generics (Generic) +import GHC.Prim (int2Word#) +import GHC.Word (Word32 (W32#)) -- | Colours supported by the major frontends. data Color = @@ -59,6 +58,59 @@ defFG :: Color defFG = White +-- | A helper for the terminal frontends that display bright via bold. +isBright :: Color -> Bool +isBright c = c >= BrBlack + +-- | Colour sets. +darkCol, brightCol, stdCol :: [Color] +darkCol = [Red .. Cyan] +brightCol = [BrRed .. BrCyan] -- BrBlack is not really that bright +stdCol = darkCol ++ brightCol + +-- | Translationg to heavily modified Linux console color RGB values. +-- +-- Warning: SDL frontend sadly duplicates this code. +colorToRGB :: Color -> Text +colorToRGB Black = "#000000" +colorToRGB Red = "#D50000" +colorToRGB Green = "#00AA00" +colorToRGB Brown = "#CA4A00" +colorToRGB Blue = "#203AF0" +colorToRGB Magenta = "#AA00AA" +colorToRGB Cyan = "#00AAAA" +colorToRGB White = "#C5BCB8" +colorToRGB BrBlack = "#6F5F5F" +colorToRGB BrRed = "#FF5555" +colorToRGB BrGreen = "#75FF45" +colorToRGB BrYellow = "#FFE855" +colorToRGB BrBlue = "#4090FF" +colorToRGB BrMagenta = "#FF77FF" +colorToRGB BrCyan = "#60FFF0" +colorToRGB BrWhite = "#FFFFFF" + +-- | For reference, the original Linux console colors. +-- Good old retro feel and more useful than xterm (e.g. brown). +_olorToRGB :: Color -> Text +_olorToRGB Black = "#000000" +_olorToRGB Red = "#AA0000" +_olorToRGB Green = "#00AA00" +_olorToRGB Brown = "#AA5500" +_olorToRGB Blue = "#0000AA" +_olorToRGB Magenta = "#AA00AA" +_olorToRGB Cyan = "#00AAAA" +_olorToRGB White = "#AAAAAA" +_olorToRGB BrBlack = "#555555" +_olorToRGB BrRed = "#FF5555" +_olorToRGB BrGreen = "#55FF55" +_olorToRGB BrYellow = "#FFFF55" +_olorToRGB BrBlue = "#5555FF" +_olorToRGB BrMagenta = "#FF55FF" +_olorToRGB BrCyan = "#55FFFF" +_olorToRGB BrWhite = "#FFFFFF" + +-- | Additional map cell highlight, e.g., a colorful square around the cell +-- or a colorful background. data Highlight = HighlightNone | HighlightRed @@ -75,10 +127,10 @@ instance Hashable Highlight --- | Text attributes: foreground and backgroud colors. +-- | Text attributes: foreground color and highlight. data Attr = Attr { fg :: Color -- ^ foreground colour - , bg :: Highlight -- ^ backgroud highlight + , bg :: Highlight -- ^ highlight } deriving (Show, Eq, Ord) @@ -91,6 +143,7 @@ defAttr :: Attr defAttr = Attr defFG HighlightNone +-- | Character to display, with its attribute. data AttrChar = AttrChar { acAttr :: Attr , acChar :: Char @@ -99,6 +152,7 @@ -- This implementation is faster than @Int@, because some vector updates -- can be done without going to and from @Int@. +-- | Optimized representation of 'AttrChar'. newtype AttrCharW32 = AttrCharW32 {attrCharW32 :: Word32} deriving (Show, Eq, Enum, Binary) @@ -147,57 +201,6 @@ retAttrW32 :: AttrCharW32 retAttrW32 = attrCharToW32 $ AttrChar defAttr '\n' - --- | A helper for the terminal frontends that display bright via bold. -isBright :: Color -> Bool -isBright c = c >= BrBlack - --- | Colour sets. -darkCol, brightCol, stdCol :: [Color] -darkCol = [Red .. Cyan] -brightCol = [BrRed .. BrCyan] -- BrBlack is not really that bright -stdCol = darkCol ++ brightCol - --- | Translationg to heavily modified Linux console color RGB values. --- --- Warning: SDL frontend sadly duplicates this code. -colorToRGB :: Color -> Text -colorToRGB Black = "#000000" -colorToRGB Red = "#D50000" -colorToRGB Green = "#00AA00" -colorToRGB Brown = "#CA4A00" -colorToRGB Blue = "#203AF0" -colorToRGB Magenta = "#AA00AA" -colorToRGB Cyan = "#00AAAA" -colorToRGB White = "#C5BCB8" -colorToRGB BrBlack = "#6F5F5F" -colorToRGB BrRed = "#FF5555" -colorToRGB BrGreen = "#75FF45" -colorToRGB BrYellow = "#FFE855" -colorToRGB BrBlue = "#4090FF" -colorToRGB BrMagenta = "#FF77FF" -colorToRGB BrCyan = "#60FFF0" -colorToRGB BrWhite = "#FFFFFF" - --- | For reference, the original Linux console colors. --- Good old retro feel and more useful than xterm (e.g. brown). -_olorToRGB :: Color -> Text -_olorToRGB Black = "#000000" -_olorToRGB Red = "#AA0000" -_olorToRGB Green = "#00AA00" -_olorToRGB Brown = "#AA5500" -_olorToRGB Blue = "#0000AA" -_olorToRGB Magenta = "#AA00AA" -_olorToRGB Cyan = "#00AAAA" -_olorToRGB White = "#AAAAAA" -_olorToRGB BrBlack = "#555555" -_olorToRGB BrRed = "#FF5555" -_olorToRGB BrGreen = "#55FF55" -_olorToRGB BrYellow = "#FFFF55" -_olorToRGB BrBlue = "#5555FF" -_olorToRGB BrMagenta = "#FF55FF" -_olorToRGB BrCyan = "#55FFFF" -_olorToRGB BrWhite = "#FFFFFF" attrChar2ToW32 :: Color -> Char -> AttrCharW32 {-# INLINE attrChar2ToW32 #-} diff --git a/Game/LambdaHack/Common/ContentDef.hs b/Game/LambdaHack/Common/ContentDef.hs --- a/Game/LambdaHack/Common/ContentDef.hs +++ b/Game/LambdaHack/Common/ContentDef.hs @@ -2,11 +2,12 @@ -- and game content, defined completely afresh for the particular game. -- The general type of the content is @ContentDef@ and it has instances -- for all content kinds, such as items kinds --- (@Game.LambdaHack.Content.ItemKind@). --- The possible kinds are fixed in the library and all defined in the same --- directory. On the other hand, game content, that is all elements --- of @ContentDef@ instances, are defined in a directory --- of the game code proper, with names corresponding to their kinds. +-- ("Game.LambdaHack.Content.ItemKind"). +-- +-- The possible kinds are fixed in the library and all defined within +-- the library source code directory. On the other hand, game content, +-- that is the values whose types are @ContentDef@ instances, +-- are defined in the directory hosting the particular game definition. module Game.LambdaHack.Common.ContentDef ( ContentDef(..), contentFromList ) where diff --git a/Game/LambdaHack/Common/Dice.hs b/Game/LambdaHack/Common/Dice.hs --- a/Game/LambdaHack/Common/Dice.hs +++ b/Game/LambdaHack/Common/Dice.hs @@ -1,122 +1,66 @@ {-# LANGUAGE DeriveGeneric, FlexibleInstances, TypeSynonymInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} --- | Representation of dice for parameters scaled with current level depth. +-- | Representation of dice scaled with current level depth. module Game.LambdaHack.Common.Dice ( -- * Frequency distribution for casting dice scaled with level depth - Dice, diceConst, diceLevel, diceMult, (|*|) - , d, dl, intToDice - , maxDice, minDice, meanDice, reduceDice + Dice, castDice, d, dl, z, zl, intToDice + , minmaxDice, maxDice, minDice, meanDice, reduceDice -- * Dice for rolling a pair of integer parameters representing coordinates. , DiceXY(..), maxDiceXY, minDiceXY, meanDiceXY -#ifdef EXPOSE_INTERNAL - -- * Internal operations - , SimpleDice -#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Control.Applicative import Control.DeepSeq import Data.Binary -import qualified Data.Char as Char import Data.Hashable (Hashable) -import qualified Data.IntMap.Strict as IM -import qualified Data.Text as T -import Data.Tuple +import Game.LambdaHack.Common.Misc import GHC.Generics (Generic) -import Game.LambdaHack.Common.Frequency - -type SimpleDice = Frequency Int - -normalizeSimple :: SimpleDice -> SimpleDice -normalizeSimple fr = toFreq (nameFrequency fr) - $ map swap $ IM.toAscList $ IM.fromListWith (+) - $ map swap $ runFrequency fr - --- Normalized mainly as an optimization, but it also makes many expected --- algebraic laws hold (wrt @Eq@), except for some laws about --- multiplication. We use @liftA2@ instead of @liftM2@, because it's probably --- faster in this case. -instance Num SimpleDice where - fr1 + fr2 = normalizeSimple $ liftA2AdditiveName "+" (+) fr1 fr2 - fr1 * fr2 = - let frRes = normalizeSimple $ do - n <- fr1 - sum $ replicate n fr2 -- not commutative! - nameRes = - case T.uncons $ nameFrequency fr2 of - _ | nameFrequency fr1 == "0" || nameFrequency fr2 == "0" -> "0" - Just ('d', _) | T.all Char.isDigit $ nameFrequency fr1 -> - nameFrequency fr1 <> nameFrequency fr2 - _ -> nameFrequency fr1 <+> "*" <+> nameFrequency fr2 - in renameFreq nameRes frRes - fr1 - fr2 = normalizeSimple $ liftA2AdditiveName "-" (-) fr1 fr2 - negate = liftAName "-" negate - abs = normalizeSimple . liftAName "abs" abs - signum = normalizeSimple . liftAName "signum" signum - fromInteger n = renameFreq (tshow n) $ pure $ fromInteger n - -liftAName :: Text -> (Int -> Int) -> SimpleDice -> SimpleDice -liftAName name f fr = - let frRes = f <$> fr - nameRes = name <> " (" <> nameFrequency fr <> ")" - in renameFreq nameRes frRes - -liftA2AdditiveName :: Text - -> (Int -> Int -> Int) - -> SimpleDice -> SimpleDice -> SimpleDice -liftA2AdditiveName name f fra frb = - let frRes = liftA2 f fra frb - nameRes - | nameFrequency fra == "0" = - (if name == "+" then "" else name) <+> nameFrequency frb - | nameFrequency frb == "0" = nameFrequency fra - | otherwise = nameFrequency fra <+> name <+> nameFrequency frb - in renameFreq nameRes frRes - -dieSimple :: Int -> SimpleDice -dieSimple n = uniformFreq ("d" <> tshow n) [1..n] - -zdieSimple :: Int -> SimpleDice -zdieSimple n = uniformFreq ("z" <> tshow n) [0..n-1] - -dieLevelSimple :: Int -> SimpleDice -dieLevelSimple n = uniformFreq ("dl" <> tshow n) [1..n] - -zdieLevelSimple :: Int -> SimpleDice -zdieLevelSimple n = uniformFreq ("zl" <> tshow n) [0..n-1] - --- | 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. --- The result if then multiplied by the scale --- to be used to ensure --- that dice results are multiples of, e.g., 10. The scale is set with @|*|@. +-- | Multiple dice rolls, some scaled with current level depth, in which case +-- the sum of all rolls is scaled in proportion to current depth +-- divided by maximal dungeon depth. -- --- Dice like 100d100 lead to enormous lists, so we help a bit --- by keeping simple dice nonstrict below. -data Dice = Dice - { diceConst :: ~SimpleDice - , diceLevel :: ~SimpleDice - , diceMult :: Int - } +-- The simple dice should have positive number of rolls and number of sides. +-- +-- The @Num@ instance doesn't have @abs@ nor @signum@ defined, +-- because the functions for computing minimum, maximum and mean dice +-- results would be too costly. +data Dice = + DiceI Int + | DiceD Int Int + | DiceDL Int Int + | DiceZ Int Int + | DiceZL Int Int + | DicePlus Dice Dice + | DiceTimes Dice Dice + | DiceNegate Dice deriving (Eq, Ord, Generic) instance Show Dice where - show Dice{..} = T.unpack $ - let rawMult = nameFrequency diceLevel - scaled = if rawMult == "0" then "" else rawMult - signAndMult = case T.uncons scaled of - Just ('-', _) -> scaled - _ -> "+" <+> scaled - in (if | nameFrequency diceLevel == "0" -> nameFrequency diceConst - | nameFrequency diceConst == "0" -> scaled - | otherwise -> nameFrequency diceConst <+> signAndMult) - <+> if diceMult == 1 then "" else "|*|" <+> tshow diceMult + show dice1 = case dice1 of + DiceI k -> show k + DiceD n k -> show n ++ "d" ++ show k + DiceDL n k -> show n ++ "dl" ++ show k + DiceZ n k -> show n ++ "z" ++ show k + DiceZL n k -> show n ++ "zl" ++ show k + DicePlus d1 (DiceNegate d2) | simpleDice d2 -> show d1 ++ "-" ++ show d2 + DicePlus d1 (DiceNegate d2) -> show d1 ++ "-" ++ "(" ++ show d2 ++ ")" + DicePlus d1 d2 -> show d1 ++ "+" ++ show d2 + DiceTimes d1 d2 -> "(" ++ show d1 ++ ") * (" ++ show d2 ++ ")" -- rare + DiceNegate (DiceI k) -> "-" ++ show k -- "-2" parses as this, not as DiceI + DiceNegate d1 -> "- (" ++ show d1 ++ ")" +simpleDice :: Dice -> Bool +simpleDice DiceI{} = True +simpleDice DiceD{} = True +simpleDice DiceDL{} = True +simpleDice DiceZ{} = True +simpleDice DiceZL{} = True +simpleDice _ = False + instance Hashable Dice instance Binary Dice @@ -124,95 +68,150 @@ instance NFData Dice instance Num Dice where - (Dice dc1 dl1 ds1) + (Dice dc2 dl2 ds2) = - Dice (scaleFreq ds1 dc1 + scaleFreq ds2 dc2) - (scaleFreq ds1 dl1 + scaleFreq ds2 dl2) - (if ds1 == 1 && ds2 == 1 then 1 else - error $ "|*| must be at top level" `showFailure` (ds1, ds2)) - (Dice dc1 dl1 ds1) * (Dice dc2 dl2 ds2) = - -- Hacky, but necessary (unless we forgo general multiplication and - -- stick to multiplications by a scalar from the left and from the right). - -- The pseudo-reasoning goes (remember the multiplication - -- is not commutative, so we take all kinds of liberties): - -- (dc1 + dl1 * l) * (dc2 + dl2 * l) - -- = dc1 * dc2 + dc1 * dl2 * l + dl1 * l * dc2 + dl1 * l * dl2 * l - -- = dc1 * dc2 + (dc1 * dl2) * l + (dl1 * dc2) * l + (dl1 * dl2) * l * l - -- Now, we don't have a slot to put the coefficient of l * l into - -- (and we don't know l yet, so we can't eliminate it by division), - -- so we happily ignore it. Done. It works well in the cases that interest - -- us, that is, multiplication by a scalar (a one-element frequency - -- distribution) from any side, unscaled and scaled by level depth - -- (but when we multiply two scaled scalars, we get 0). - Dice (scaleFreq ds1 dc1 * scaleFreq ds2 dc2) - (scaleFreq ds1 dc1 * scaleFreq ds2 dl2 - + scaleFreq ds1 dl1 * scaleFreq ds2 dc2) - (if ds1 == 1 && ds2 == 1 then 1 else - error $ "|*| must be at top level" `showFailure` (ds1, ds2)) - (Dice dc1 dl1 ds1) - (Dice dc2 dl2 ds2) = - Dice (scaleFreq ds1 dc1 - scaleFreq ds2 dc2) - (scaleFreq ds1 dl1 - scaleFreq ds2 dl2) - (if ds1 == 1 && ds2 == 1 then 1 else - error $ "|*| must be at top level" `showFailure` (ds1, ds2)) - negate = affectBothDice negate - abs = affectBothDice abs - signum = affectBothDice signum - fromInteger n = Dice (fromInteger n) 0 1 + d1 + d2 = DicePlus d1 d2 + d1 * d2 = DiceTimes d1 d2 + d1 - d2 = d1 + DiceNegate d2 + negate = DiceNegate + abs = undefined + signum = undefined + fromInteger n = DiceI (fromInteger n) -affectBothDice :: (SimpleDice -> SimpleDice) -> Dice -> Dice -affectBothDice f (Dice dc1 dl1 ds1) = Dice (f dc1) (f dl1) ds1 +-- | Cast dice scaled with current level depth. +-- Note that at the first level, the scaled dice are always ignored. +-- +-- The implementation calls RNG as many times as there are dice rolls, +-- which is costly, so content should prefer to case fewer dice +-- and then multiply them by a constant. If rounded results are not desired +-- (often they are, to limit the number of distinct item varieties +-- in inventory), another dice may be added to the result. +-- +-- A different possible implementation, with dice represented as 'Frequency', +-- makes only one RNG call per dice, but due to lists lengths proportional +-- to the maximal value of the dice, it's is intractable for 1000d1000 +-- and problematic already for 100d100. +castDice :: forall m. Monad m + => ((Int, Int) -> m Int) + -> AbsDepth -> AbsDepth -> Dice -> m Int +castDice randomR (AbsDepth lvlDepth) (AbsDepth maxDepth) dice = do + let !_A = assert (lvlDepth >= 0 && lvlDepth <= maxDepth + `blame` "invalid depth for dice rolls" + `swith` (lvlDepth, maxDepth)) () + castNK n start k = do + let f !acc 0 = return acc + f acc count = do + r <- randomR (start, k) + f (acc + r) (count - 1) + f 0 n + scaleL k = (k * max 0 (lvlDepth - 1)) `div` max 1 (maxDepth - 1) + castD :: Dice -> m Int + castD dice1 = case dice1 of + DiceI k -> return k + DiceD n k -> castNK n 1 k + DiceDL n k -> scaleL <$> castNK n 1 k + DiceZ n k -> castNK n 0 (k - 1) + DiceZL n k -> scaleL <$> castNK n 0 (k - 1) + DicePlus d1 d2 -> do + k1 <- castD d1 + k2 <- castD d2 + return $! k1 + k2 + DiceTimes d1 d2 -> do + k1 <- castD d1 + k2 <- castD d2 + return $! k1 * k2 + DiceNegate d1 -> do + k <- castD d1 + return $! negate k + castD dice --- | A single simple dice. -d :: Int -> Dice -d n = Dice (dieSimple n) 0 1 +-- | A die, rolled the given number of times. E.g., @1 `d` 2@ rolls 2-sided +-- die one time. +d :: Int -> Int -> Dice +d n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k)) + $ DiceD n k --- | Dice scaled with level. -dl :: Int -> Dice -dl n = Dice 0 (dieLevelSimple n) 1 +-- | A die rolled the given number of times, with the result scaled +-- with dungeon level depth. +dl :: Int -> Int -> Dice +dl n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k)) + $ DiceDL n k --- Not exposed to save on documentation. -_z :: Int -> Dice -_z n = Dice (zdieSimple n) 0 1 +-- | A die, starting from zero, ending at one less than the bound, +-- rolled the given number of times. E.g., @1 `z` 1@ always rolls zero. +z :: Int -> Int -> Dice +z n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k)) + $ DiceZ n k -_zl :: Int -> Dice -_zl n = Dice 0 (zdieLevelSimple n) 1 +-- | A die, starting from zero, ending at one less than the bound, +-- rolled the given number of times, +-- with the result scaled with dungeon level depth. +zl :: Int -> Int -> Dice +zl n k = assert (n > 0 && k > 0 `blame` "die must be positive" `swith` (n, k)) + $ DiceZL n k intToDice :: Int -> Dice -intToDice = fromInteger . fromIntegral +intToDice = DiceI -infixl 5 |*| --- | Multiplying the dice, after all randomness is resolved, by a constant. --- Infix declaration ensures that @1 + 2 |*| 3@ parses as @(1 + 2) |*| 3@. -(|*|) :: Dice -> Int -> Dice -Dice dc1 dl1 ds1 |*| s2 = Dice dc1 dl1 (ds1 * s2) +-- | Minimal and maximal possible value of the dice. +-- +-- @divUp@ in the implementation corresponds to @ceiling@, +-- applied to results of @meanDice@ elsewhere in the code, +-- and prevents treating 1d1-power effects (on shallow levels) as null effects. +minmaxDice :: Dice -> (Int, Int) +minmaxDice dice1 = case dice1 of + DiceI k -> (k, k) + DiceD n k -> (n, n * k) + DiceDL n k -> (0, n * k) -- bottom and top level considered + DiceZ n k -> (0, n * (k - 1)) + DiceZL n k -> (0, n * (k - 1)) -- bottom and top level considered + DicePlus d1 d2 -> + let (minD1, maxD1) = minmaxDice d1 + (minD2, maxD2) = minmaxDice d2 + in (minD1 + minD2, maxD1 + maxD2) + DiceTimes (DiceI k) d2 -> + let (minD2, maxD2) = minmaxDice d2 + in if k >= 0 then (k * minD2, k * maxD2) else (k * maxD2, k * minD2) + DiceTimes d1 (DiceI k) -> + let (minD1, maxD1) = minmaxDice d1 + in if k >= 0 then (minD1 * k, maxD1 * k) else (maxD1 * k, minD1 * k) + -- Multiplication other than the two cases above is unlikely, but here it is. + DiceTimes d1 d2 -> + let (minD1, maxD1) = minmaxDice d1 + (minD2, maxD2) = minmaxDice d2 + options = [minD1 * minD2, minD1 * maxD2, maxD1 * maxD2, maxD1 * minD2] + in (minimum options, maximum options) + DiceNegate d1 -> + let (minD1, maxD1) = minmaxDice d1 + in (negate maxD1, negate minD1) -- | Maximal value of dice. The scaled part taken assuming median level. maxDice :: Dice -> Int -maxDice Dice{..} = (fromMaybe 0 (maxFreq diceConst) - + fromMaybe 0 (maxFreq diceLevel) `div` 2) - * diceMult +maxDice = snd . minmaxDice -- | Minimal value of dice. The scaled part taken assuming median level. minDice :: Dice -> Int -minDice Dice{..} = (fromMaybe 0 (minFreq diceConst) - + fromMaybe 0 (minFreq diceLevel) `div` 2) - * diceMult +minDice = fst . minmaxDice -- | Mean value of dice. The scaled part taken assuming median level. --- Assumes the frequencies are not null. -meanDice :: Dice -> Int -meanDice Dice{..} = (meanFreq diceConst - + meanFreq diceLevel `div` 2) - * diceMult +meanDice :: Dice -> Double +meanDice dice1 = case dice1 of + DiceI k -> fromIntegral k + DiceD n k -> fromIntegral (n * (k + 1)) / 2 + DiceDL n k -> fromIntegral (n * (k + 1)) / 4 + DiceZ n k -> fromIntegral (n * k) / 2 + DiceZL n k -> fromIntegral (n * k) / 4 + DicePlus d1 d2 -> meanDice d1 + meanDice d2 + DiceTimes d1 d2 -> meanDice d1 * meanDice d2 -- I hope this is that simple + DiceNegate d1 -> negate $ meanDice d1 reduceDice :: Dice -> Maybe Int -reduceDice de = - let minD = minDice de - in if minD == maxDice de then Just minD else Nothing +reduceDice d1 = + let (minD1, maxD1) = minmaxDice d1 + in if minD1 == maxD1 then Just minD1 else Nothing -- | Dice for rolling a pair of integer parameters pertaining to, -- respectively, the X and Y cartesian 2D coordinates. data DiceXY = DiceXY Dice Dice - deriving (Show, Eq, Ord, Generic) + deriving (Show, Generic) instance Hashable DiceXY @@ -227,5 +226,5 @@ minDiceXY (DiceXY x y) = (minDice x, minDice y) -- | Mean value of DiceXY. -meanDiceXY :: DiceXY -> (Int, Int) +meanDiceXY :: DiceXY -> (Double, Double) meanDiceXY (DiceXY x y) = (meanDice x, meanDice y) diff --git a/Game/LambdaHack/Common/Faction.hs b/Game/LambdaHack/Common/Faction.hs --- a/Game/LambdaHack/Common/Faction.hs +++ b/Game/LambdaHack/Common/Faction.hs @@ -1,10 +1,10 @@ {-# LANGUAGE DeriveGeneric #-} --- | Factions taking part in the game: e.g., two human players controlling --- the hero faction battling the monster and the animal factions. +-- | Factions taking part in the game, e.g., a hero faction, a monster faction +-- and an animal faction. module Game.LambdaHack.Common.Faction ( FactionId, FactionDict, Faction(..), Diplomacy(..), Status(..) - , Target(..), TGoal(..), Challenge(..), tgtKindDescription - , isHorrorFact, nameOfHorrorFact + , Target(..), TGoal(..), Challenge(..) + , gleader, tgtKindDescription, isHorrorFact, nameOfHorrorFact , noRunWithMulti, isAIFact, autoDungeonLevel, automatePlayer , isAtWar, isAllied , difficultyBound, difficultyDefault, difficultyCoeff, difficultyInverse @@ -19,25 +19,26 @@ import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.IntMap.Strict as IM -import GHC.Generics (Generic) +import GHC.Generics (Generic) import qualified Game.LambdaHack.Common.Ability as Ability -import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.ItemKind (ItemKind) -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Content.ModeKind -- | All factions in the game, indexed by faction identifier. type FactionDict = EM.EnumMap FactionId Faction +-- | The faction datatype. data Faction = Faction { gname :: Text -- ^ individual name , gcolor :: Color.Color -- ^ color of actors or their frames @@ -46,14 +47,14 @@ , gdipl :: Dipl -- ^ diplomatic mode , gquit :: Maybe Status -- ^ cause of game end/exit , _gleader :: Maybe ActorId -- ^ the leader of the faction; don't use - -- in place of _sleader on clients + -- in place of sleader on clients , gsha :: ItemBag -- ^ faction's shared inventory , gvictims :: EM.EnumMap (Kind.Id ItemKind) Int -- ^ members killed , gvictimsD :: EM.EnumMap (Kind.Id ModeKind) (IM.IntMap (EM.EnumMap (Kind.Id ItemKind) Int)) -- ^ members killed in the past, by game mode and difficulty level } - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Generic) instance Binary Faction @@ -90,17 +91,19 @@ instance Binary Target +-- | The goal of an actor. data TGoal = TEnemyPos ActorId Bool -- ^ last seen position of the targeted actor | TEmbed ItemBag Point - -- ^ in @TPoint (TEmbed bag p) _ q@ usually @bag@ is embbedded in @p@ - -- and @q@ is an adjacent open tile - | TItem ItemBag - | TSmell - | TUnknown - | TKnown - | TAny + -- ^ embedded item that can be triggered; + -- in @TPoint (TEmbed bag p) _ q@ usually @bag@ is embbedded in @p@ + -- and @q@ is an adjacent open tile + | TItem ItemBag -- ^ item lying on the ground + | TSmell -- ^ smell potentially left by enemies + | TUnknown -- ^ an unknown tile to be explored + | TKnown -- ^ a known tile to be patrolled + | TAny -- ^ an unspecified goal deriving (Show, Eq, Ord, Generic) instance Binary TGoal @@ -113,6 +116,9 @@ deriving (Show, Eq, Ord, Generic) instance Binary Challenge + +gleader :: Faction -> Maybe ActorId +gleader = _gleader tgtKindDescription :: Target -> Text tgtKindDescription tgt = case tgt of diff --git a/Game/LambdaHack/Common/File.hs b/Game/LambdaHack/Common/File.hs --- a/Game/LambdaHack/Common/File.hs +++ b/Game/LambdaHack/Common/File.hs @@ -1,4 +1,4 @@ --- | Saving/loading with serialization and compression. +-- | Saving/loading to files, with serialization and compression. module Game.LambdaHack.Common.File ( encodeEOF, strictDecodeEOF , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile diff --git a/Game/LambdaHack/Common/Flavour.hs b/Game/LambdaHack/Common/Flavour.hs --- a/Game/LambdaHack/Common/Flavour.hs +++ b/Game/LambdaHack/Common/Flavour.hs @@ -4,11 +4,15 @@ ( -- * The @Flavour@ type Flavour , -- * Constructors - zipPlain, zipFancy, stdFlav, zipLiquid + zipPlain, zipFancy, zipLiquid, stdFlav , -- * Accessors flavourToColor, flavourToName -- * Assorted - , colorToTeamName, colorToPlainName, colorToFancyName + , colorToPlainName, colorToFancyName, colorToTeamName +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , FancyName, colorToLiquidName +#endif ) where import Prelude () diff --git a/Game/LambdaHack/Common/Frequency.hs b/Game/LambdaHack/Common/Frequency.hs --- a/Game/LambdaHack/Common/Frequency.hs +++ b/Game/LambdaHack/Common/Frequency.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveFoldable, DeriveGeneric, DeriveTraversable #-} --- | A list of items with relative frequencies of appearance. +-- | A list of entities with relative frequencies of appearance. module Game.LambdaHack.Common.Frequency ( -- * The @Frequency@ type Frequency @@ -20,6 +20,7 @@ import Control.DeepSeq import Data.Binary import Data.Hashable (Hashable) +import Data.Int (Int32) import Data.Ord (comparing) import GHC.Generics (Generic) @@ -29,31 +30,43 @@ -- -- The @Eq@ instance compares raw representations, not relative, -- normalized frequencies, so operations don't need to preserve --- the expected equalities, unless they do some kind of normalization --- (see 'Dice'). +-- the expected equalities. data Frequency a = Frequency { runFrequency :: [(Int, a)] -- ^ give acces to raw frequency values - , nameFrequency :: ~Text -- ^ short description for debug, etc.; - -- keep it lazy, because it's rarely used + , nameFrequency :: Text -- ^ short description for debug, etc. } deriving (Show, Eq, Ord, Foldable, Traversable, Generic) +_maxBound32 :: Integer +_maxBound32 = toInteger (maxBound :: Int32) + instance Monad Frequency where - {-# INLINE return #-} - return x = Frequency [(1, x)] "return" Frequency xs name >>= f = - Frequency [ (p * q, y) | (p, x) <- xs - , (q, y) <- runFrequency (f x) ] + Frequency [ +#ifdef WITH_EXPENSIVE_ASSERTIONS + assert (toInteger p * toInteger q <= _maxBound32) +#endif + (p * q, y) + | (p, x) <- xs + , (q, y) <- runFrequency (f x) + ] ("bind (" <> name <> ")") instance Functor Frequency where fmap f (Frequency xs name) = Frequency (map (second f) xs) name instance Applicative Frequency where - pure = return + {-# INLINE pure #-} + pure x = Frequency [(1, x)] "pure" Frequency fs fname <*> Frequency ys yname = - Frequency [ (p * q, f y) | (p, f) <- fs - , (q, y) <- ys ] + Frequency [ +#ifdef WITH_EXPENSIVE_ASSERTIONS + assert (toInteger p * toInteger q <= _maxBound32) +#endif + (p * q, f y) + | (p, f) <- fs + , (q, y) <- ys + ] ("(" <> fname <> ") <*> (" <> yname <> ")") instance MonadPlus Frequency where @@ -83,14 +96,23 @@ -- | Takes a name and a list of frequencies and items -- into the frequency distribution. toFreq :: Text -> [(Int, a)] -> Frequency a -toFreq name l = Frequency (filter ((> 0 ) . fst) l) name +toFreq name l = +#ifdef WITH_EXPENSIVE_ASSERTIONS + assert (all (\(p, _) -> toInteger p <= _maxBound32) l) $ +#endif + Frequency (filter ((> 0 ) . fst) l) name -- | Scale frequency distribution, multiplying it -- by a positive integer constant. scaleFreq :: Show a => Int -> Frequency a -> Frequency a scaleFreq n (Frequency xs name) = assert (n > 0 `blame` "non-positive frequency scale" `swith` (name, n, xs)) $ - Frequency (map (first (* n)) xs) name + let multN p = +#ifdef WITH_EXPENSIVE_ASSERTIONS + assert (toInteger p * toInteger n <= _maxBound32) $ +#endif + p * n + in Frequency (map (first multN) xs) name -- | Change the description of the frequency. renameFreq :: Text -> Frequency a -> Frequency a diff --git a/Game/LambdaHack/Common/HSFile.hs b/Game/LambdaHack/Common/HSFile.hs --- a/Game/LambdaHack/Common/HSFile.hs +++ b/Game/LambdaHack/Common/HSFile.hs @@ -1,7 +1,11 @@ --- | Saving/loading with serialization and compression. +-- | Saving/loading to files, with serialization and compression. module Game.LambdaHack.Common.HSFile ( encodeEOF, strictDecodeEOF , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , encodeData +#endif ) where import Prelude () @@ -10,12 +14,12 @@ import qualified Codec.Compression.Zlib as Z import qualified Control.Exception as Ex -import Data.Binary +import Data.Binary import qualified Data.ByteString.Lazy as LBS -import System.Directory -import System.FilePath -import System.IO (IOMode (..), hClose, openBinaryFile, readFile, withBinaryFile, - writeFile) +import System.Directory +import System.FilePath +import System.IO (IOMode (..), hClose, openBinaryFile, readFile, + withBinaryFile, writeFile) -- | Serialize, compress and save data. -- Note that LBS.writeFile opens the file in binary mode. diff --git a/Game/LambdaHack/Common/HighScore.hs b/Game/LambdaHack/Common/HighScore.hs --- a/Game/LambdaHack/Common/HighScore.hs +++ b/Game/LambdaHack/Common/HighScore.hs @@ -1,11 +1,11 @@ {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | High score table operations. module Game.LambdaHack.Common.HighScore - ( ScoreDict, ScoreTable + ( ScoreTable, ScoreDict , empty, register, showScore, getTable, getRecord, highSlideshow #ifdef EXPOSE_INTERNAL -- * Internal operations - , ScoreRecord + , ScoreRecord, insertPos, showTable, showNearbyScores #endif ) where @@ -13,21 +13,22 @@ import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.Text as T -import Data.Time.Clock.POSIX -import Data.Time.LocalTime -import GHC.Generics (Generic) +import Data.Time.Clock.POSIX +import Data.Time.LocalTime +import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Content.ItemKind (ItemKind) -import Game.LambdaHack.Content.ModeKind (HiCondPoly, HiIndeterminant (..), - ModeKind, Outcome (..)) +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Content.ModeKind (HiCondPoly, + HiIndeterminant (..), + ModeKind, Outcome (..)) -- | A single score record. Records are ordered in the highscore table, -- from the best to the worst, in lexicographic ordering wrt the fields below. @@ -41,7 +42,7 @@ , ourVictims :: EM.EnumMap (Kind.Id ItemKind) Int -- ^ allies lost , theirVictims :: EM.EnumMap (Kind.Id ItemKind) Int -- ^ foes killed } - deriving (Eq, Ord, Show, Generic) + deriving (Show, Eq, Ord, Generic) instance Binary ScoreRecord @@ -55,42 +56,6 @@ -- | A dictionary from game mode IDs to scores tables. type ScoreDict = EM.EnumMap (Kind.Id ModeKind) ScoreTable --- | Show a single high score, from the given ranking in the high score table. -showScore :: TimeZone -> (Int, ScoreRecord) -> [Text] -showScore tz (pos, score) = - let Status{stOutcome, stDepth} = status score - died = case stOutcome of - Killed -> "perished on level" <+> tshow (abs stDepth) - Defeated -> "got defeated" - Camping -> "set camp" - Conquer -> "slew all opposition" - Escape -> "emerged victorious" - Restart -> "resigned prematurely" - curDate = tshow . utcToLocalTime tz . posixSecondsToUTCTime . date $ score - turns = absoluteTimeNegate (negTime score) `timeFitUp` timeTurn - tpos = T.justifyRight 3 ' ' $ tshow pos - tscore = T.justifyRight 6 ' ' $ tshow $ points score - victims = let nkilled = sum $ EM.elems $ theirVictims score - nlost = sum $ EM.elems $ ourVictims score - in "killed" <+> tshow nkilled <> ", lost" <+> tshow nlost - diff = cdiff $ challenge score - diffText | diff == difficultyDefault = "" - | otherwise = "difficulty" <+> tshow diff <> ", " - tturns = makePhrase [MU.CarWs turns "turn"] - in [ tpos <> "." <+> tscore <+> gplayerName score - <+> died <> "," <+> victims <> "," - , " " - <> diffText <> "after" <+> tturns <+> "on" <+> curDate <> "." - ] - -getTable :: Kind.Id ModeKind -> ScoreDict -> ScoreTable -getTable = EM.findWithDefault (ScoreTable []) - -getRecord :: Int -> ScoreTable -> ScoreRecord -getRecord pos (ScoreTable table) = - fromMaybe (error $ "" `showFailure` (pos, table)) - $ listToMaybe $ drop (pred pos) table - -- | Empty score table empty :: ScoreDict empty = EM.empty @@ -140,6 +105,42 @@ negTime = absoluteTimeNegate time score = ScoreRecord{..} in (points > 0, insertPos score table) + +-- | Show a single high score, from the given ranking in the high score table. +showScore :: TimeZone -> (Int, ScoreRecord) -> [Text] +showScore tz (pos, score) = + let Status{stOutcome, stDepth} = status score + died = case stOutcome of + Killed -> "perished on level" <+> tshow (abs stDepth) + Defeated -> "got defeated" + Camping -> "set camp" + Conquer -> "slew all opposition" + Escape -> "emerged victorious" + Restart -> "resigned prematurely" + curDate = tshow . utcToLocalTime tz . posixSecondsToUTCTime . date $ score + turns = absoluteTimeNegate (negTime score) `timeFitUp` timeTurn + tpos = T.justifyRight 3 ' ' $ tshow pos + tscore = T.justifyRight 6 ' ' $ tshow $ points score + victims = let nkilled = sum $ EM.elems $ theirVictims score + nlost = sum $ EM.elems $ ourVictims score + in "killed" <+> tshow nkilled <> ", lost" <+> tshow nlost + diff = cdiff $ challenge score + diffText | diff == difficultyDefault = "" + | otherwise = "difficulty" <+> tshow diff <> ", " + tturns = makePhrase [MU.CarWs turns "turn"] + in [ tpos <> "." <+> tscore <+> gplayerName score + <+> died <> "," <+> victims <> "," + , " " + <> diffText <> "after" <+> tturns <+> "on" <+> curDate <> "." + ] + +getTable :: Kind.Id ModeKind -> ScoreDict -> ScoreTable +getTable = EM.findWithDefault (ScoreTable []) + +getRecord :: Int -> ScoreTable -> ScoreRecord +getRecord pos (ScoreTable table) = + fromMaybe (error $ "" `showFailure` (pos, table)) + $ listToMaybe $ drop (pred pos) table -- | Show a screenful of the high scores table. -- Parameter height is the number of (3-line) scores to be shown. diff --git a/Game/LambdaHack/Common/Item.hs b/Game/LambdaHack/Common/Item.hs --- a/Game/LambdaHack/Common/Item.hs +++ b/Game/LambdaHack/Common/Item.hs @@ -1,20 +1,22 @@ {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | Weapons, treasure and all the other items in the game. --- No operation in this module involves the state or any of our custom monads. module Game.LambdaHack.Common.Item - ( -- * The @Item@ type - ItemId, Item(..), ItemSource(..) - , itemPrice, goesIntoEqp, isMelee, goesIntoInv, goesIntoSha - , seedToAspect, meanAspect, aspectRecordToList - , aspectRecordFull, aspectsRandom - -- * Item discovery types - , ItemKindIx, ItemSeed, KindMean(..), DiscoveryKind - , Benefit(..), DiscoveryBenefit - , AspectRecord(..), emptyAspectRecord, sumAspectRecord, DiscoveryAspect - , ItemFull(..), ItemDisco(..) - , itemNoDisco, itemToFull + ( -- * The @Item@ type and operations + ItemId, Item(..) + , itemPrice, isMelee, goesIntoEqp, goesIntoInv, goesIntoSha + -- * The @AspectRecord@ type and operations + , AspectRecord(..), DiscoveryAspect + , emptyAspectRecord, sumAspectRecord, aspectRecordToList, meanAspect + -- * Item discovery types and operations + , ItemKindIx, ItemSeed, ItemDisco(..), ItemFull(..) + , KindMean(..), DiscoveryKind, ItemIxMap, Benefit(..), DiscoveryBenefit + , itemNoDisco, itemToFull6, aspectsRandom, seedToAspect, aspectRecordFull -- * Inventory management types , ItemTimer, ItemQuant, ItemBag, ItemDict +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , castAspect, addMeanAspect, ceilingMeanDice +#endif ) where import Prelude () @@ -22,70 +24,73 @@ import Game.LambdaHack.Common.Prelude import qualified Control.Monad.Trans.State.Strict as St -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM -import Data.Hashable (Hashable) +import Data.Hashable (Hashable) import qualified Data.Ix as Ix -import GHC.Generics (Generic) -import System.Random (mkStdGen) +import GHC.Generics (Generic) +import System.Random (mkStdGen) import qualified Game.LambdaHack.Common.Ability as Ability -import Game.LambdaHack.Common.Dice (intToDice) +import Game.LambdaHack.Common.Dice (intToDice) import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Flavour +import Game.LambdaHack.Common.Flavour import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.Time import qualified Game.LambdaHack.Content.ItemKind as IK -- | A unique identifier of an item in the dungeon. newtype ItemId = ItemId Int deriving (Show, Eq, Ord, Enum, Binary) --- | An index of the kind id of an item. Clients have partial knowledge --- how these idexes map to kind ids. They gain knowledge by identifying items. -newtype ItemKindIx = ItemKindIx Int - deriving (Show, Eq, Ord, Enum, Ix.Ix, Hashable, Binary) - -data KindMean = KindMean - { kmKind :: Kind.Id IK.ItemKind - , kmMean :: AspectRecord +-- | Game items in actor possesion or strewn around the dungeon. +-- The fields @jsymbol@, @jname@ and @jflavour@ make it possible to refer to +-- and draw an unidentified item. Full information about item is available +-- through the @jkindIx@ index as soon as the item is identified. +data Item = Item + { jkindIx :: ItemKindIx -- ^ index pointing to the kind of the item + , jlid :: LevelId -- ^ lowest level the item was created at + , jfid :: Maybe FactionId + -- ^ the faction that created the item, if any + , jsymbol :: Char -- ^ map symbol + , jname :: Text -- ^ generic name + , jflavour :: Flavour -- ^ flavour + , jfeature :: [IK.Feature] -- ^ public properties + , jweight :: Int -- ^ weight in grams, obvious enough + , jdamage :: Dice.Dice -- ^ impact damage of this particular weapon } deriving (Show, Eq, Generic) -instance Binary KindMean +instance Hashable Item --- | The map of item kind indexes to item kind ids. --- The full map, as known by the server, is 1-1. -type DiscoveryKind = EM.EnumMap ItemKindIx KindMean +instance Binary Item --- | Fields are intentionally kept non-strict, because they are recomputed --- often, but not used every time. The fields are, in order: --- 1. whether the item should be kept in equipment (not in pack nor stash) --- 2. the total benefit from picking the item up (to use or to put in equipment) --- 3. the benefit of applying the item to self --- 4. the (usually negative) benefit of hitting a foe in meleeing with the item --- 5. the (usually negative) benefit of flinging an item at an opponent -data Benefit = Benefit - { benInEqp :: ~Bool - , benPickup :: ~Int - , benApply :: ~Int - , benMelee :: ~Int - , benFling :: ~Int - } - deriving (Show, Generic) +-- | Price an item, taking count into consideration. +itemPrice :: (Item, Int) -> Int +itemPrice (item, jcount) = + case jsymbol item of + '$' -> jcount + '*' -> jcount * 100 + _ -> 0 -instance Binary Benefit +isMelee :: Item -> Bool +isMelee item = IK.Meleeable `elem` jfeature item -type DiscoveryBenefit = EM.EnumMap ItemId Benefit +goesIntoEqp :: Item -> Bool +goesIntoEqp item = IK.Equipable `elem` jfeature item + || IK.Meleeable `elem` jfeature item --- | A seed for rolling aspects of an item --- Clients have partial knowledge of how item ids map to the seeds. --- They gain knowledge by identifying items. -newtype ItemSeed = ItemSeed Int - deriving (Show, Eq, Ord, Enum, Hashable, Binary) +goesIntoInv :: Item -> Bool +goesIntoInv item = IK.Precious `notElem` jfeature item + && not (goesIntoEqp item) +goesIntoSha :: Item -> Bool +goesIntoSha item = IK.Precious `elem` jfeature item + && not (goesIntoEqp item) + +-- | Record of sums of aspect values of an item, container, actor, etc. data AspectRecord = AspectRecord { aTimeout :: Int , aHurtMelee :: Int @@ -107,6 +112,10 @@ instance Hashable AspectRecord +-- | The map of item ids to item aspects. +-- The full map is known by the server. +type DiscoveryAspect = EM.EnumMap ItemId AspectRecord + emptyAspectRecord :: AspectRecord emptyAspectRecord = AspectRecord { aTimeout = 0 @@ -144,21 +153,100 @@ mapScale f = map (\(ar, k) -> f ar * k) mapScaleAbility = map (\(ar, k) -> Ability.scaleSkills k $ aSkills ar) --- | The map of item ids to item aspects. --- The full map is known by the server. -type DiscoveryAspect = EM.EnumMap ItemId AspectRecord +aspectRecordToList :: AspectRecord -> [IK.Aspect] +aspectRecordToList AspectRecord{..} = + [IK.Timeout $ intToDice aTimeout | aTimeout /= 0] + ++ [IK.AddHurtMelee $ intToDice aHurtMelee | aHurtMelee /= 0] + ++ [IK.AddArmorMelee $ intToDice aArmorMelee | aArmorMelee /= 0] + ++ [IK.AddArmorRanged $ intToDice aArmorRanged | aArmorRanged /= 0] + ++ [IK.AddMaxHP $ intToDice aMaxHP | aMaxHP /= 0] + ++ [IK.AddMaxCalm $ intToDice aMaxCalm | aMaxCalm /= 0] + ++ [IK.AddSpeed $ intToDice aSpeed | aSpeed /= 0] + ++ [IK.AddSight $ intToDice aSight | aSight /= 0] + ++ [IK.AddSmell $ intToDice aSmell | aSmell /= 0] + ++ [IK.AddShine $ intToDice aShine | aShine /= 0] + ++ [IK.AddNocto $ intToDice aNocto | aNocto /= 0] + ++ [IK.AddAggression $ intToDice aAggression | aAggression /= 0] + ++ [IK.AddAbility ab $ intToDice n | (ab, n) <- EM.assocs aSkills, n /= 0] +meanAspect :: IK.ItemKind -> AspectRecord +meanAspect kind = foldl' addMeanAspect emptyAspectRecord (IK.iaspects kind) + +addMeanAspect :: AspectRecord -> IK.Aspect -> AspectRecord +addMeanAspect !ar !asp = + case asp of + IK.Timeout d -> + let n = ceilingMeanDice d + in assert (aTimeout ar == 0) $ ar {aTimeout = n} + IK.AddHurtMelee d -> + let n = ceilingMeanDice d + in ar {aHurtMelee = n + aHurtMelee ar} + IK.AddArmorMelee d -> + let n = ceilingMeanDice d + in ar {aArmorMelee = n + aArmorMelee ar} + IK.AddArmorRanged d -> + let n = ceilingMeanDice d + in ar {aArmorRanged = n + aArmorRanged ar} + IK.AddMaxHP d -> + let n = ceilingMeanDice d + in ar {aMaxHP = n + aMaxHP ar} + IK.AddMaxCalm d -> + let n = ceilingMeanDice d + in ar {aMaxCalm = n + aMaxCalm ar} + IK.AddSpeed d -> + let n = ceilingMeanDice d + in ar {aSpeed = n + aSpeed ar} + IK.AddSight d -> + let n = ceilingMeanDice d + in ar {aSight = n + aSight ar} + IK.AddSmell d -> + let n = ceilingMeanDice d + in ar {aSmell = n + aSmell ar} + IK.AddShine d -> + let n = ceilingMeanDice d + in ar {aShine = n + aShine ar} + IK.AddNocto d -> + let n = ceilingMeanDice d + in ar {aNocto = n + aNocto ar} + IK.AddAggression d -> + let n = ceilingMeanDice d + in ar {aAggression = n + aAggression ar} + IK.AddAbility ab d -> + let n = ceilingMeanDice d + in ar {aSkills = Ability.addSkills (EM.singleton ab n) + (aSkills ar)} + +ceilingMeanDice :: Dice.Dice -> Int +ceilingMeanDice d = ceiling $ Dice.meanDice d + +-- | An index of the kind identifier of an item. Clients have partial knowledge +-- how these idexes map to kind ids. They gain knowledge by identifying items. +-- The indexes and kind identifiers are 1-1. +newtype ItemKindIx = ItemKindIx Int + deriving (Show, Eq, Ord, Enum, Ix.Ix, Hashable, Binary) + +-- | A seed for rolling aspects of an item +-- Clients have partial knowledge of how item ids map to the seeds. +-- They gain knowledge by identifying items. +newtype ItemSeed = ItemSeed Int + deriving (Show, Eq, Ord, Enum, Hashable, Binary) + -- Tiny speedup from making fields non-strict (1%, a bit more GC, less alloc). -- The fields of @KindMean@ also need to be non-strict then, otherwise slowdown. +-- | The secret part of the information about an item. If a faction +-- knows the aspects of the item (the 'itemAspect' field is not empty), +-- this is a complete secret information/. data ItemDisco = ItemDisco { itemKindId :: Kind.Id IK.ItemKind , itemKind :: IK.ItemKind , itemAspectMean :: AspectRecord + , itemConst :: Bool , itemAspect :: Maybe AspectRecord } deriving Show -- No speedup from making fields non-strict. +-- | Full information about an item. data ItemFull = ItemFull { itemBase :: Item , itemK :: Int @@ -167,92 +255,82 @@ } deriving Show -itemNoDisco :: (Item, Int) -> ItemFull -itemNoDisco (itemBase, itemK) = - ItemFull {itemBase, itemK, itemTimer = [], itemDisco=Nothing} - -itemToFull :: Kind.COps -> DiscoveryKind -> DiscoveryAspect -> ItemId -> Item - -> ItemQuant - -> ItemFull -itemToFull Kind.COps{coitem=Kind.Ops{okind}} - disco discoAspect iid itemBase (itemK, itemTimer) = - let itemDisco = case EM.lookup (jkindIx itemBase) disco of - Nothing -> Nothing - Just KindMean{..} -> Just ItemDisco{ itemKindId = kmKind - , itemKind = okind kmKind - , itemAspectMean = kmMean - , itemAspect = EM.lookup iid discoAspect } - in ItemFull {..} - --- | Game items in actor possesion or strewn around the dungeon. --- The fields @jsymbol@, @jname@ and @jflavour@ make it possible to refer to --- and draw an unidentified item. Full information about item is available --- through the @jkindIx@ index as soon as the item is identified. -data Item = Item - { jkindIx :: ItemKindIx -- ^ index pointing to the kind of the item - , jlid :: LevelId -- ^ lowest level the item was created at - , jfid :: Maybe FactionId - -- ^ the faction that created the item, if any - , jsymbol :: Char -- ^ map symbol - , jname :: Text -- ^ generic name - , jflavour :: Flavour -- ^ flavour - , jfeature :: [IK.Feature] -- ^ public properties - , jweight :: Int -- ^ weight in grams, obvious enough - , jdamage :: Dice.Dice -- ^ impact damage of this particular weapon +-- | Partial information about item kinds. These are assigned to each +-- 'ItemKindIx'. There is an item kinda, mean aspect value computed +-- (and here cached) for items of that kind and a flag saying whether +-- the item's aspects are constant rather than random or dependent +-- on dungeon level where the item is created. +data KindMean = KindMean + { kmKind :: Kind.Id IK.ItemKind + , kmMean :: AspectRecord + , kmConst :: Bool } deriving (Show, Eq, Generic) -instance Hashable Item - -instance Binary Item +instance Binary KindMean -data ItemSource = - ItemSourceLevel LevelId - | ItemSourceFaction FactionId - deriving (Show, Eq, Generic) +-- | The map of item kind indexes to item kind ids. +-- The full map, as known by the server, is 1-1. +type DiscoveryKind = EM.EnumMap ItemKindIx KindMean -instance Hashable ItemSource +-- | The map of item kind indexes to identifiers of items that have that kind. +type ItemIxMap = EM.EnumMap ItemKindIx [ItemId] -instance Binary ItemSource +-- | Fields are intentionally kept non-strict, because they are recomputed +-- often, but not used every time. The fields are, in order: +-- 1. whether the item should be kept in equipment (not in pack nor stash) +-- 2. the total benefit from picking the item up (to use or to put in equipment) +-- 3. the benefit of applying the item to self +-- 4. the (usually negative) benefit of hitting a foe in meleeing with the item +-- 5. the (usually negative) benefit of flinging an item at an opponent +data Benefit = Benefit + { benInEqp :: ~Bool + , benPickup :: ~Double + , benApply :: ~Double + , benMelee :: ~Double + , benFling :: ~Double + } + deriving (Show, Generic) --- | Price an item, taking count into consideration. -itemPrice :: (Item, Int) -> Int -itemPrice (item, jcount) = - case jsymbol item of - '$' -> jcount - '*' -> jcount * 100 - _ -> 0 +instance Binary Benefit -goesIntoEqp :: Item -> Bool -goesIntoEqp item = IK.Equipable `elem` jfeature item - || IK.Meleeable `elem` jfeature item +type DiscoveryBenefit = EM.EnumMap ItemId Benefit -isMelee :: Item -> Bool -isMelee item = IK.Meleeable `elem` jfeature item +itemNoDisco :: (Item, Int) -> ItemFull +itemNoDisco (itemBase, itemK) = + ItemFull {itemBase, itemK, itemTimer = [], itemDisco=Nothing} -goesIntoInv :: Item -> Bool -goesIntoInv item = IK.Precious `notElem` jfeature item - && not (goesIntoEqp item) +itemToFull6 :: Kind.COps -> DiscoveryKind -> DiscoveryAspect -> ItemId -> Item + -> ItemQuant + -> ItemFull +itemToFull6 Kind.COps{coitem=Kind.Ops{okind}} + discoKind discoAspect iid itemBase (itemK, itemTimer) = + let itemDisco = case EM.lookup (jkindIx itemBase) discoKind of + Nothing -> Nothing + Just KindMean{..} -> + Just ItemDisco{ itemKindId = kmKind + , itemKind = okind kmKind + , itemAspectMean = kmMean + , itemConst = kmConst + , itemAspect = EM.lookup iid discoAspect } + in ItemFull {..} -goesIntoSha :: Item -> Bool -goesIntoSha item = IK.Precious `elem` jfeature item - && not (goesIntoEqp item) +-- If @False@, aspects of this kind are most probably fixed, not random +-- nor dependent on dungeon level where the item is created. +aspectsRandom :: IK.ItemKind -> Bool +aspectsRandom kind = + let rollM depth = foldlM' (castAspect (AbsDepth depth) (AbsDepth 10)) + emptyAspectRecord (IK.iaspects kind) + gen = mkStdGen 0 + (ar0, gen0) = St.runState (rollM 0) gen + (ar1, gen1) = St.runState (rollM 10) gen0 + in show gen /= show gen0 || show gen /= show gen1 || ar0 /= ar1 -aspectRecordToList :: AspectRecord -> [IK.Aspect] -aspectRecordToList AspectRecord{..} = - [IK.Timeout $ intToDice aTimeout | aTimeout /= 0] - ++ [IK.AddHurtMelee $ intToDice aHurtMelee | aHurtMelee /= 0] - ++ [IK.AddArmorMelee $ intToDice aArmorMelee | aArmorMelee /= 0] - ++ [IK.AddArmorRanged $ intToDice aArmorRanged | aArmorRanged /= 0] - ++ [IK.AddMaxHP $ intToDice aMaxHP | aMaxHP /= 0] - ++ [IK.AddMaxCalm $ intToDice aMaxCalm | aMaxCalm /= 0] - ++ [IK.AddSpeed $ intToDice aSpeed | aSpeed /= 0] - ++ [IK.AddSight $ intToDice aSight | aSight /= 0] - ++ [IK.AddSmell $ intToDice aSmell | aSmell /= 0] - ++ [IK.AddShine $ intToDice aShine | aShine /= 0] - ++ [IK.AddNocto $ intToDice aNocto | aNocto /= 0] - ++ [IK.AddAggression $ intToDice aAggression | aAggression /= 0] - ++ [IK.AddAbility ab $ intToDice n | (ab, n) <- EM.assocs aSkills, n /= 0] +seedToAspect :: ItemSeed -> IK.ItemKind -> AbsDepth -> AbsDepth -> AspectRecord +seedToAspect (ItemSeed itemSeed) kind ldepth totalDepth = + let rollM = foldlM' (castAspect ldepth totalDepth) emptyAspectRecord + (IK.iaspects kind) + in St.evalState rollM (mkStdGen itemSeed) castAspect :: AbsDepth -> AbsDepth -> AspectRecord -> IK.Aspect -> Rnd AspectRecord @@ -299,67 +377,6 @@ return $! ar {aSkills = Ability.addSkills (EM.singleton ab n) (aSkills ar)} -addMeanAspect :: AspectRecord -> IK.Aspect -> AspectRecord -addMeanAspect !ar !asp = - case asp of - IK.Timeout d -> - let n = Dice.meanDice d - in assert (aTimeout ar == 0) $ ar {aTimeout = n} - IK.AddHurtMelee d -> - let n = Dice.meanDice d - in ar {aHurtMelee = n + aHurtMelee ar} - IK.AddArmorMelee d -> - let n = Dice.meanDice d - in ar {aArmorMelee = n + aArmorMelee ar} - IK.AddArmorRanged d -> - let n = Dice.meanDice d - in ar {aArmorRanged = n + aArmorRanged ar} - IK.AddMaxHP d -> - let n = Dice.meanDice d - in ar {aMaxHP = n + aMaxHP ar} - IK.AddMaxCalm d -> - let n = Dice.meanDice d - in ar {aMaxCalm = n + aMaxCalm ar} - IK.AddSpeed d -> - let n = Dice.meanDice d - in ar {aSpeed = n + aSpeed ar} - IK.AddSight d -> - let n = Dice.meanDice d - in ar {aSight = n + aSight ar} - IK.AddSmell d -> - let n = Dice.meanDice d - in ar {aSmell = n + aSmell ar} - IK.AddShine d -> - let n = Dice.meanDice d - in ar {aShine = n + aShine ar} - IK.AddNocto d -> - let n = Dice.meanDice d - in ar {aNocto = n + aNocto ar} - IK.AddAggression d -> - let n = Dice.meanDice d - in ar {aAggression = n + aAggression ar} - IK.AddAbility ab d -> - let n = Dice.meanDice d - in ar {aSkills = Ability.addSkills (EM.singleton ab n) - (aSkills ar)} - -seedToAspect :: ItemSeed -> IK.ItemKind -> AbsDepth -> AbsDepth -> AspectRecord -seedToAspect (ItemSeed itemSeed) kind ldepth totalDepth = - let rollM = foldlM' (castAspect ldepth totalDepth) emptyAspectRecord - (IK.iaspects kind) - in St.evalState rollM (mkStdGen itemSeed) - --- If @False@, aspects of this kind are most probably fixed, not random. -aspectsRandom :: IK.ItemKind -> Bool -aspectsRandom kind = - let rollM = foldlM' (castAspect (AbsDepth 10) (AbsDepth 10)) - emptyAspectRecord (IK.iaspects kind) - gen = mkStdGen 0 - in show gen /= show (St.execState rollM gen) - -meanAspect :: IK.ItemKind -> AspectRecord -meanAspect kind = foldl' addMeanAspect emptyAspectRecord (IK.iaspects kind) - aspectRecordFull :: ItemFull -> AspectRecord aspectRecordFull itemFull = case itemDisco itemFull of @@ -369,8 +386,13 @@ type ItemTimer = [Time] +-- | Number of items in a bag, together with recharging timer, in case of +-- items that need recharging, exists only temporarily or auto-activate +-- at regular intervals. type ItemQuant = (Int, ItemTimer) +-- | A bag of items, e.g., one of the stores of an actor or the items +-- on a particular floor position or embedded in a particular map tile. type ItemBag = EM.EnumMap ItemId ItemQuant -- | All items in the dungeon (including in actor inventories), diff --git a/Game/LambdaHack/Common/ItemStrongest.hs b/Game/LambdaHack/Common/ItemStrongest.hs --- a/Game/LambdaHack/Common/ItemStrongest.hs +++ b/Game/LambdaHack/Common/ItemStrongest.hs @@ -1,13 +1,16 @@ -- | Determining the strongest item wrt some property. --- No operation in this module involves the state or any of our custom monads. module Game.LambdaHack.Common.ItemStrongest ( -- * Strongest items - strengthOnSmash, strengthCreateOrgan, strengthDropOrgan - , strengthEqpSlot, strengthToThrow, strengthEffect, strongestSlot + strengthEffect, strengthOnSmash, strengthCreateOrgan, strengthDropOrgan + , strengthEqpSlot, strengthToThrow, strongestSlot -- * Assorted - , totalRange, computeTrajectory, itemTrajectory - , unknownMelee, filterRecharging, stripRecharging, stripOnSmash + , computeTrajectory, itemTrajectory, totalRange , hasCharge, damageUsefulness, strongestMelee, prEqpSlot + , unknownMeleeBonus, filterRecharging, stripRecharging, stripOnSmash +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , unknownAspect +#endif ) where import Prelude () @@ -19,12 +22,12 @@ import qualified Game.LambdaHack.Common.Ability as Ability import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.ItemKind +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.ItemKind strengthEffect :: (Effect -> [b]) -> ItemFull -> [b] strengthEffect f itemFull = @@ -71,6 +74,27 @@ [x] -> x xs -> error $ "" `showFailure` (xs, item) +-- This ignores items that don't go into equipment, as determined in @inEqp@. +-- They are removed from equipment elsewhere via @harmful@. +strongestSlot :: DiscoveryBenefit -> EqpSlot -> [(ItemId, ItemFull)] + -> [(Int, (ItemId, ItemFull))] +strongestSlot discoBenefit eqpSlot is = + let f (iid, itemFull) = + let rawDmg = damageUsefulness $ itemBase itemFull + (bInEqp, bPickup) = case EM.lookup iid discoBenefit of + Just Benefit{benInEqp, benPickup} -> (benInEqp, benPickup) + Nothing -> (goesIntoEqp $ itemBase itemFull, rawDmg) + in if not bInEqp + then Nothing + else Just $ + let ben = if eqpSlot == EqpSlotWeapon + -- For equipping/unequipping a weapon we take into + -- account not only melee power, but also aspects, etc. + then ceiling bPickup + else prEqpSlot eqpSlot $ aspectRecordFull itemFull + in (ben, (iid, itemFull)) + in sortBy (flip $ Ord.comparing fst) $ mapMaybe f is + computeTrajectory :: Int -> Int -> Int -> [Point] -> ([Vector], (Speed, Int)) computeTrajectory weight throwVelocity throwLinger path = let speed = speedFromWeight weight throwVelocity @@ -86,37 +110,6 @@ totalRange :: Item -> Int totalRange item = snd $ snd $ itemTrajectory item [] -prEqpSlot :: EqpSlot -> AspectRecord -> Int -prEqpSlot eqpSlot ar@AspectRecord{..} = - case eqpSlot of - EqpSlotMiscBonus -> - aTimeout -- usually better items have longer timeout - + aMaxCalm + aSmell - + aNocto -- powerful, but hard to boost over aSight - EqpSlotAddHurtMelee -> aHurtMelee - EqpSlotAddArmorMelee -> aArmorMelee - EqpSlotAddArmorRanged -> aArmorRanged - EqpSlotAddMaxHP -> aMaxHP - EqpSlotAddSpeed -> aSpeed - EqpSlotAddSight -> aSight - EqpSlotLightSource -> aShine - EqpSlotWeapon -> error $ "" `showFailure` ar - EqpSlotMiscAbility -> - EM.findWithDefault 0 Ability.AbWait aSkills - + EM.findWithDefault 0 Ability.AbMoveItem aSkills - EqpSlotAbMove -> EM.findWithDefault 0 Ability.AbMove aSkills - EqpSlotAbMelee -> EM.findWithDefault 0 Ability.AbMelee aSkills - EqpSlotAbDisplace -> EM.findWithDefault 0 Ability.AbDisplace aSkills - EqpSlotAbAlter -> EM.findWithDefault 0 Ability.AbAlter aSkills - EqpSlotAbProject -> EM.findWithDefault 0 Ability.AbProject aSkills - EqpSlotAbApply -> EM.findWithDefault 0 Ability.AbApply aSkills - EqpSlotAddMaxCalm -> aMaxCalm - EqpSlotAddSmell -> aSmell - EqpSlotAddNocto -> aNocto - EqpSlotAddAggression -> aAggression - EqpSlotAbWait -> EM.findWithDefault 0 Ability.AbWait aSkills - EqpSlotAbMoveItem -> EM.findWithDefault 0 Ability.AbMoveItem aSkills - hasCharge :: Time -> ItemFull -> Bool hasCharge localTime itemFull@ItemFull{..} = let timeout = aTimeout $ aspectRecordFull itemFull @@ -125,12 +118,12 @@ it1 = filter charging itemTimer in length it1 < itemK -damageUsefulness :: Item -> Int +damageUsefulness :: Item -> Double damageUsefulness item = let v = min 1000 (10 * Dice.meanDice (jdamage item)) in assert (v >= 0) v strongestMelee :: Maybe DiscoveryBenefit -> Time -> [(ItemId, ItemFull)] - -> [(Int, (ItemId, ItemFull))] + -> [(Double, (ItemId, ItemFull))] strongestMelee _ _ [] = [] strongestMelee mdiscoBenefit localTime is = -- For simplicity we assume, if weapon not recharged, all important effects, @@ -150,37 +143,48 @@ -- e.g., geysers, bees. This is intended and fun. in sortBy (flip $ Ord.comparing fst) $ map f is --- This ignores items that don't go into equipment, as determined in @inEqp@. --- They are removed from equipment elsewhere via @harmful@. -strongestSlot :: DiscoveryBenefit -> EqpSlot -> [(ItemId, ItemFull)] - -> [(Int, (ItemId, ItemFull))] -strongestSlot discoBenefit eqpSlot is = - let f (iid, itemFull) = - let rawDmg = damageUsefulness $ itemBase itemFull - (bInEqp, bPickup) = case EM.lookup iid discoBenefit of - Just Benefit{benInEqp, benPickup} -> (benInEqp, benPickup) - Nothing -> (goesIntoEqp $ itemBase itemFull, rawDmg) - in if not bInEqp - then Nothing - else Just $ - let ben = if eqpSlot == EqpSlotWeapon - -- For equipping/unequipping a weapon we take into - -- account not only melee power, but also aspects, etc. - then bPickup - else prEqpSlot eqpSlot $ aspectRecordFull itemFull - in (ben, (iid, itemFull)) - in sortBy (flip $ Ord.comparing fst) $ mapMaybe f is +prEqpSlot :: EqpSlot -> AspectRecord -> Int +prEqpSlot eqpSlot ar@AspectRecord{..} = + case eqpSlot of + EqpSlotMiscBonus -> + aTimeout -- usually better items have longer timeout + + aMaxCalm + aSmell + + aNocto -- powerful, but hard to boost over aSight + EqpSlotAddHurtMelee -> aHurtMelee + EqpSlotAddArmorMelee -> aArmorMelee + EqpSlotAddArmorRanged -> aArmorRanged + EqpSlotAddMaxHP -> aMaxHP + EqpSlotAddSpeed -> aSpeed + EqpSlotAddSight -> aSight + EqpSlotLightSource -> aShine + EqpSlotWeapon -> error $ "" `showFailure` ar + EqpSlotMiscAbility -> + EM.findWithDefault 0 Ability.AbWait aSkills + + EM.findWithDefault 0 Ability.AbMoveItem aSkills + EqpSlotAbMove -> EM.findWithDefault 0 Ability.AbMove aSkills + EqpSlotAbMelee -> EM.findWithDefault 0 Ability.AbMelee aSkills + EqpSlotAbDisplace -> EM.findWithDefault 0 Ability.AbDisplace aSkills + EqpSlotAbAlter -> EM.findWithDefault 0 Ability.AbAlter aSkills + EqpSlotAbProject -> EM.findWithDefault 0 Ability.AbProject aSkills + EqpSlotAbApply -> EM.findWithDefault 0 Ability.AbApply aSkills + EqpSlotAddMaxCalm -> aMaxCalm + EqpSlotAddSmell -> aSmell + EqpSlotAddNocto -> aNocto + EqpSlotAddAggression -> aAggression + EqpSlotAbWait -> EM.findWithDefault 0 Ability.AbWait aSkills + EqpSlotAbMoveItem -> EM.findWithDefault 0 Ability.AbMoveItem aSkills unknownAspect :: (Aspect -> [Dice.Dice]) -> ItemFull -> Bool unknownAspect f itemFull = case itemDisco itemFull of + Nothing -> True -- not even kind is known, so aspect unknown Just ItemDisco{itemAspect=Nothing, itemKind=ItemKind{iaspects}} -> let unknown x = Dice.minDice x /= Dice.maxDice x in or $ concatMap (map unknown . f) iaspects - _ -> False -- we don't know if it affect the aspect, so we assume 0 + Just{} -> False -- all known -unknownMelee :: [ItemFull] -> Bool -unknownMelee = +unknownMeleeBonus :: [ItemFull] -> Bool +unknownMeleeBonus = let p (AddHurtMelee k) = [k] p _ = [] f itemFull b = b || unknownAspect p itemFull diff --git a/Game/LambdaHack/Common/JSFile.hs b/Game/LambdaHack/Common/JSFile.hs --- a/Game/LambdaHack/Common/JSFile.hs +++ b/Game/LambdaHack/Common/JSFile.hs @@ -1,4 +1,4 @@ --- | Saving/loading with serialization and compression. +-- | Saving/loading to JS storeage, mimicking operations on files. module Game.LambdaHack.Common.JSFile ( encodeEOF, strictDecodeEOF , tryCreateDir, doesFileExist, tryWriteFile, readFile, renameFile @@ -8,14 +8,14 @@ import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Text as T -import Data.Text.Encoding (decodeLatin1) -import GHCJS.DOM (currentWindow) -import GHCJS.DOM.Storage (getItem, removeItem, setItem) -import GHCJS.DOM.Types (runDOM) -import GHCJS.DOM.Window (getLocalStorage) +import Data.Text.Encoding (decodeLatin1) +import GHCJS.DOM (currentWindow) +import GHCJS.DOM.Storage (getItem, removeItem, setItem) +import GHCJS.DOM.Types (runDOM) +import GHCJS.DOM.Window (getLocalStorage) -- | Serialize and save data with an EOF marker. In JS, compression -- is probably performed by the browser and we don't have access @@ -54,7 +54,6 @@ let fileExists = isJust (mitem :: Maybe String) return $! fileExists --- | Try to write a file, given content, if the file not already there. tryWriteFile :: FilePath -> String -> IO () tryWriteFile path content = flip runDOM undefined $ do Just win <- currentWindow diff --git a/Game/LambdaHack/Common/Kind.hs b/Game/LambdaHack/Common/Kind.hs --- a/Game/LambdaHack/Common/Kind.hs +++ b/Game/LambdaHack/Common/Kind.hs @@ -1,6 +1,7 @@ +{-# OPTIONS_GHC -fno-expose-all-unfoldings #-} -- | General content types and operations. module Game.LambdaHack.Common.Kind - ( Id, Ops(..), COps(..), createOps, stdRuleset + ( Id, Ops(..), COps(..), stdRuleset, createOps ) where import Prelude () @@ -23,10 +24,34 @@ import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind --- Not specialized, because no speedup, but huge JS code bloat. +-- | Operations for all content types, gathered together. +data COps = COps + { cocave :: Ops CaveKind -- server only + , coitem :: Ops ItemKind + , comode :: Ops ModeKind -- server only + , coplace :: Ops PlaceKind -- server only, so far + , corule :: Ops RuleKind + , cotile :: Ops TileKind + , coTileSpeedup :: TileSpeedup + } + +instance Show COps where + show _ = "game content" + +instance Eq COps where + (==) _ _ = True + +-- | The standard ruleset used for level operations. +stdRuleset :: Ops RuleKind -> RuleKind +stdRuleset Ops{ouniqGroup, okind} = okind $ ouniqGroup "standard" + +-- Not specialized, because no speedup, but big JS code bloat +-- (-fno-expose-all-unfoldings and NOINLINE used to ensure that, +-- in the absence of NOSPECIALIZABLE pragma). -- | Create content operations for type @a@ from definition of content -- of type @a@. createOps :: forall a. Show a => ContentDef a -> Ops a +{-# NOINLINE createOps #-} createOps ContentDef{getName, getFreq, content, validateSingle, validateAll} = assert (V.length content <= fromEnum (maxBound :: Id a)) $ let kindFreq :: M.Map (GroupName a) [(Int, (Id a, a))] @@ -87,24 +112,3 @@ `showFailure` () , olength = V.length content } - --- | Operations for all content types, gathered together. -data COps = COps - { cocave :: Ops CaveKind -- server only - , coitem :: Ops ItemKind - , comode :: Ops ModeKind -- server only - , coplace :: Ops PlaceKind -- server only, so far - , corule :: Ops RuleKind - , cotile :: Ops TileKind - , coTileSpeedup :: TileSpeedup - } - -instance Show COps where - show _ = "game content" - -instance Eq COps where - (==) _ _ = True - --- | The standard ruleset used for level operations. -stdRuleset :: Ops RuleKind -> RuleKind -stdRuleset Ops{ouniqGroup, okind} = okind $ ouniqGroup "standard" diff --git a/Game/LambdaHack/Common/Level.hs b/Game/LambdaHack/Common/Level.hs --- a/Game/LambdaHack/Common/Level.hs +++ b/Game/LambdaHack/Common/Level.hs @@ -5,34 +5,40 @@ LevelId, AbsDepth, Dungeon , ascendInBranch, whereTo -- * The @Level@ type and its components - , Level(..), ItemFloor, ActorMap, TileMap, SmellMap + , ItemFloor, ActorMap, TileMap, SmellMap, Level(..) + -- * Component updates + , updateFloor, updateEmbed, updateActorMap, updateTile, updateSmell -- * Level query , at, findPoint, findPos, findPosTry, findPosTry2 +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , assertSparseItems, assertSparseActors +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import qualified Game.LambdaHack.Common.KindOps as KindOps -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Content.ItemKind (ItemKind) -import Game.LambdaHack.Content.TileKind (TileKind) +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Content.TileKind (TileKind) --- | The complete dungeon is a map from level names to levels. +-- | The complete dungeon is a map from level identifiers to levels. type Dungeon = EM.EnumMap LevelId Level --- | Levels in the current branch, @k@ levels shallower than the current. +-- | Levels in the current branch, one level up (or down) from the current. ascendInBranch :: Dungeon -> Bool -> LevelId -> [LevelId] ascendInBranch dungeon up lid = -- Currently there is just one branch, so the computation is simple. @@ -92,13 +98,12 @@ data Level = Level { ldepth :: AbsDepth -- ^ absolute depth of the level , lfloor :: ItemFloor -- ^ remembered items lying on the floor - , lembed :: ItemFloor -- ^ items embedded in the tile + , lembed :: ItemFloor -- ^ remembered items embedded in the tile , lactor :: ActorMap -- ^ seen actors at positions on the level , 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]) -- ^ positions of (up, down) stairs , lseen :: Int -- ^ currently remembered clear tiles @@ -111,7 +116,9 @@ , litemFreq :: Freqs ItemKind -- ^ frequency of initial items; [] for clients , lescape :: [Point] -- ^ positions of IK.Escape tiles - , lnight :: Bool + , lnight :: Bool -- ^ whether the level is covered in darkness + , lname :: Text -- ^ level name + , ldesc :: Text -- ^ level description } deriving (Show, Eq) @@ -125,6 +132,21 @@ assert (EM.null (EM.filter null m) `blame` "null actor lists found" `swith` m) m +updateFloor :: (ItemFloor -> ItemFloor) -> Level -> Level +updateFloor f lvl = lvl {lfloor = f (lfloor lvl)} + +updateEmbed :: (ItemFloor -> ItemFloor) -> Level -> Level +updateEmbed f lvl = lvl {lembed = f (lembed lvl)} + +updateActorMap :: (ActorMap -> ActorMap) -> Level -> Level +updateActorMap f lvl = lvl {lactor = f (lactor lvl)} + +updateTile :: (TileMap -> TileMap) -> Level -> Level +updateTile f lvl = lvl {ltile = f (ltile lvl)} + +updateSmell :: (SmellMap -> SmellMap) -> Level -> Level +updateSmell f lvl = lvl {lsmell = f (lsmell lvl)} + -- | Query for tile kinds on the map. at :: Level -> Point -> Kind.Id TileKind {-# INLINE at #-} @@ -203,7 +225,6 @@ put lxsize put lysize put lsmell - put ldesc put lstair put lseen put lexplorable @@ -214,6 +235,8 @@ put litemFreq put lescape put lnight + put lname + put ldesc get = do ldepth <- get lfloor <- get @@ -223,7 +246,6 @@ lxsize <- get lysize <- get lsmell <- get - ldesc <- get lstair <- get lseen <- get lexplorable <- get @@ -234,4 +256,6 @@ litemFreq <- get lescape <- get lnight <- get + lname <- get + ldesc <- get return $! Level{..} diff --git a/Game/LambdaHack/Common/Misc.hs b/Game/LambdaHack/Common/Misc.hs --- a/Game/LambdaHack/Common/Misc.hs +++ b/Game/LambdaHack/Common/Misc.hs @@ -3,95 +3,53 @@ -- | Hacks that haven't found their home yet. module Game.LambdaHack.Common.Misc ( -- * Game object identifiers - FactionId, LevelId, AbsDepth(..), ActorId + FactionId, LevelId, ActorId -- * Item containers , Container(..), CStore(..), ItemDialogMode(..) -- * Assorted - , makePhrase, makeSentence - , normalLevelBound, GroupName, toGroupName, Freqs, breturn - , Rarity, validateRarity - , Tactic(..), describeTactic, appDataDir - , xM, minusM, minusM1, oneM + , GroupName, Freqs, Rarity, AbsDepth(..), Tactic(..) + , toGroupName, validateRarity, describeTactic + , makePhrase, makeSentence, normalLevelBound, breturn + , appDataDir, xM, xD, minusM, minusM1, oneM ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Control.DeepSeq -import Data.Binary +import Control.DeepSeq +import Data.Binary import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Fixed as Fixed -import Data.Function -import Data.Hashable +import Data.Function +import Data.Hashable import qualified Data.HashMap.Strict as HM -import Data.Int (Int64) -import Data.Key -import Data.Ord -import Data.String (IsString (..)) +import Data.Int (Int64) +import Data.Key +import Data.Ord +import Data.String (IsString (..)) import qualified Data.Text as T import qualified Data.Time as Time -import GHC.Generics (Generic) +import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU -import System.Directory (getAppUserDataDirectory) -import System.Environment (getProgName) +import System.Directory (getAppUserDataDirectory) +import System.Environment (getProgName) import Game.LambdaHack.Common.Point --- | Re-exported English phrase creation functions, applied to default --- irregular word sets. -makePhrase, makeSentence :: [MU.Part] -> Text -makePhrase = MU.makePhrase MU.defIrregular -makeSentence = MU.makeSentence MU.defIrregular - --- | Level bounds. -normalLevelBound :: (Int, Int) -normalLevelBound = (79, 20) - --- If ever needed, we can use a symbol table here, since content --- is never serialized. But we'd need to cover the few cases --- (e.g., @litemFreq@) where @GroupName@ goes into savegame. -newtype GroupName a = GroupName Text - deriving (Read, Eq, Ord, Hashable, Binary, Generic) - -instance IsString (GroupName a) where - fromString = GroupName . T.pack - -instance Show (GroupName a) where - show (GroupName gn) = T.unpack gn - -instance NFData (GroupName a) - -toGroupName :: Text -> GroupName a -{-# INLINE toGroupName #-} -toGroupName = GroupName - --- | For each group that the kind belongs to, denoted by a @GroupName@ --- in the first component of a pair, the second component of a pair shows --- how common the kind is within the group. -type Freqs a = [(GroupName a, Int)] - --- | Rarity on given depths. -type Rarity = [(Double, Int)] +-- | A unique identifier of a faction in a game. +newtype FactionId = FactionId Int + deriving (Show, Eq, Ord, Enum, Hashable, Binary) -validateRarity :: Rarity -> [Text] -validateRarity rarity = - let sortedRarity = sortBy (comparing fst) rarity - in [ "rarity not sorted" | sortedRarity /= rarity ] - ++ [ "rarity depth thresholds not unique" - | nubBy ((==) `on` fst) sortedRarity /= sortedRarity ] - ++ [ "rarity depth not between 0 and 10" - | case (sortedRarity, reverse sortedRarity) of - ((lowest, _) : _, (highest, _) : _) -> - lowest <= 0 || highest > 10 - _ -> False ] +-- | Abstract level identifiers. +newtype LevelId = LevelId Int + deriving (Show, Eq, Ord, Enum, Hashable, Binary) --- | @breturn b a = [a | b]@ -breturn :: MonadPlus m => Bool -> a -> m a -breturn True a = return a -breturn False _ = mzero +-- | A unique identifier of an actor in the dungeon. +newtype ActorId = ActorId Int + deriving (Show, Eq, Ord, Enum, Binary) -- | Item container type. data Container = @@ -103,6 +61,7 @@ instance Binary Container +-- | Actor's item stores. data CStore = CGround | COrgan @@ -124,14 +83,28 @@ instance Binary ItemDialogMode --- | A unique identifier of a faction in a game. -newtype FactionId = FactionId Int - deriving (Show, Eq, Ord, Enum, Hashable, Binary) +-- If ever needed, we can use a symbol table here, since content +-- is never serialized. But we'd need to cover the few cases +-- (e.g., @litemFreq@) where @GroupName@ goes into savegame. +newtype GroupName a = GroupName Text + deriving (Read, Eq, Ord, Hashable, Binary, Generic) --- | Abstract level identifiers. -newtype LevelId = LevelId Int - deriving (Show, Eq, Ord, Enum, Hashable, Binary) +instance IsString (GroupName a) where + fromString = GroupName . T.pack +instance Show (GroupName a) where + show (GroupName gn) = T.unpack gn + +instance NFData (GroupName a) + +-- | For each group that the kind belongs to, denoted by a @GroupName@ +-- in the first component of a pair, the second component of a pair shows +-- how common the kind is within the group. +type Freqs a = [(GroupName a, Int)] + +-- | Rarity on given depths. +type Rarity = [(Double, Int)] + -- | Absolute depth in the dungeon. When used for the maximum depth -- of the whole dungeon, this can be different than dungeon size, -- e.g., when the dungeon is branched, and it can even be different @@ -139,10 +112,6 @@ newtype AbsDepth = AbsDepth Int deriving (Show, Eq, Ord, Hashable, Binary) --- | A unique identifier of an actor in the dungeon. -newtype ActorId = ActorId Int - deriving (Show, Eq, Ord, Enum, Binary) - -- | Tactic of non-leader actors. Apart of determining AI operation, -- each tactic implies a skill modifier, that is added to the non-leader skills -- defined in 'fskillsOther' field of 'Player'. @@ -170,6 +139,26 @@ show TRoam = "roam freely" show TPatrol = "patrol area" +instance Binary Tactic + +instance Hashable Tactic + +toGroupName :: Text -> GroupName a +{-# INLINE toGroupName #-} +toGroupName = GroupName + +validateRarity :: Rarity -> [Text] +validateRarity rarity = + let sortedRarity = sortBy (comparing fst) rarity + in [ "rarity not sorted" | sortedRarity /= rarity ] + ++ [ "rarity depth thresholds not unique" + | nubBy ((==) `on` fst) sortedRarity /= sortedRarity ] + ++ [ "rarity depth not between 0 and 10" + | case (sortedRarity, reverse sortedRarity) of + ((lowest, _) : _, (highest, _) : _) -> + lowest <= 0 || highest > 10 + _ -> False ] + describeTactic :: Tactic -> Text describeTactic TExplore = "investigate unknown positions, chase targets" describeTactic TFollow = "follow leader's target or position, grab items" @@ -182,12 +171,42 @@ describeTactic TRoam = "move freely, chase targets" describeTactic TPatrol = "find and patrol an area (WIP)" -instance Binary Tactic +-- | Re-exported English phrase creation functions, applied to default +-- irregular word sets. +makePhrase, makeSentence :: [MU.Part] -> Text +makePhrase = MU.makePhrase MU.defIrregular +makeSentence = MU.makeSentence MU.defIrregular -instance Hashable Tactic +-- | Level bounds. +normalLevelBound :: (Int, Int) +normalLevelBound = (79, 20) --- Data.Binary +-- | @breturn b a = [a | b]@ +breturn :: MonadPlus m => Bool -> a -> m a +breturn True a = return a +breturn False _ = mzero +-- | 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 + +xM :: Int -> Int64 +xM k = fromIntegral k * 1000000 + +xD :: Double -> Double +xD k = k * 1000000 + +minusM, minusM1, oneM :: Int64 +minusM = xM (-1) +minusM1 = xM (-1) - 1 +oneM = xM 1 + +-- Data.Binary orphan instances + instance (Enum k, Binary k, Binary e) => Binary (EM.EnumMap k e) where put m = put (EM.size m) >> mapM_ put (EM.toAscList m) get = EM.fromDistinctAscList <$> get @@ -204,7 +223,7 @@ get = fmap HM.fromList get put = put . HM.toList --- Data.Key +-- Data.Key orphan instances type instance Key (EM.EnumMap k) = k @@ -240,31 +259,15 @@ {-# INLINE adjust #-} adjust = EM.adjust --- Data.Hashable +-- Data.Hashable orphan instances instance (Enum k, Hashable k, Hashable e) => Hashable (EM.EnumMap k e) where hashWithSalt s x = hashWithSalt s (EM.toAscList x) --- Control.DeepSeq +-- Control.DeepSeq orphan instances instance NFData MU.Part instance NFData MU.Person instance NFData MU.Polarity - --- | 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 - -xM :: Int -> Int64 -xM k = fromIntegral k * 1000000 - -minusM, minusM1, oneM :: Int64 -minusM = xM (-1) -minusM1 = xM (-1) - 1 -oneM = xM 1 diff --git a/Game/LambdaHack/Common/MonadStateRead.hs b/Game/LambdaHack/Common/MonadStateRead.hs --- a/Game/LambdaHack/Common/MonadStateRead.hs +++ b/Game/LambdaHack/Common/MonadStateRead.hs @@ -1,6 +1,5 @@ {-# LANGUAGE TupleSections #-} --- | Game action monads and basic building blocks for human and computer --- player actions. Has no access to the main action type. +-- | Game state reading monad and basic operations. module Game.LambdaHack.Common.MonadStateRead ( MonadStateRead(..) , getState, getLevel, nUI @@ -14,17 +13,22 @@ import qualified Data.EnumMap.Strict as EM import qualified Game.LambdaHack.Common.Ability as Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemStrongest +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State +import Game.LambdaHack.Content.ModeKind +-- | Monad for reading game state. A state monad with state modification +-- disallowed (another constraint is needed to permit that). +-- The basic server and client monads are like that, because server +-- and clients freely modify their internal session data, but don't modify +-- the main game state, except in very restricted and synchronized way. class (Monad m, Functor m, Applicative m) => MonadStateRead m where getsState :: (State -> a) -> m a @@ -63,13 +67,13 @@ pickWeaponM :: MonadStateRead m => Maybe DiscoveryBenefit - -> [(ItemId, ItemFull)] -> Ability.Skills -> ActorAspect -> ActorId - -> m [(Int, (ItemId, ItemFull))] -pickWeaponM mdiscoBenefit allAssocs actorSk actorAspect source = do + -> [(ItemId, ItemFull)] -> Ability.Skills -> ActorId + -> m [(Double, (ItemId, ItemFull))] +pickWeaponM mdiscoBenefit allAssocs actorSk source = do sb <- getsState $ getActorBody source localTime <- getsState $ getLocalTime (blid sb) - let ar = actorAspect EM.! source - calmE = calmEnough sb ar + ar <- getsState $ getActorAspect source + let calmE = calmEnough sb ar forced = bproj sb permitted = permittedPrecious calmE forced preferredPrecious = either (const False) id . permitted diff --git a/Game/LambdaHack/Common/Perception.hs b/Game/LambdaHack/Common/Perception.hs --- a/Game/LambdaHack/Common/Perception.hs +++ b/Game/LambdaHack/Common/Perception.hs @@ -4,7 +4,7 @@ -- Visibility works according to KISS. Everything that player sees is real. -- There are no unmarked hidden tiles and only solid tiles can be marked, -- so there are no invisible walls and to pass through an illusory wall, --- you have use a turn bumping into it first. Only tiles marked with Suspect +-- you have to use a turn bumping into it first. Only tiles marked with Suspect -- can turn out to be another tile. (So, if all tiles are marked with -- Suspect, the player knows nothing for sure, but this should be avoided, -- because searching becomes too time-consuming.) @@ -17,8 +17,7 @@ -- the tile, so the player can flee or block. Invisible actors in open -- space can be hit. module Game.LambdaHack.Common.Perception - ( -- * Public perception - PerVisible(..) + ( PerVisible(..) , PerSmelled(..) , Perception(..) , PerLid @@ -31,16 +30,14 @@ import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import GHC.Generics (Generic) +import GHC.Generics (Generic) import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point - --- * Public perception -- | Visible positions. newtype PerVisible = PerVisible {pvisible :: ES.EnumSet Point} diff --git a/Game/LambdaHack/Common/Point.hs b/Game/LambdaHack/Common/Point.hs --- a/Game/LambdaHack/Common/Point.hs +++ b/Game/LambdaHack/Common/Point.hs @@ -4,6 +4,10 @@ ( X, Y, Point(..), maxLevelDimExponent , chessDist, euclidDistSq, adjacent, inside, bla, fromTo , originPoint +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , maxLevelDim, blaXY, balancedWord +#endif ) where import Prelude () diff --git a/Game/LambdaHack/Common/PointArray.hs b/Game/LambdaHack/Common/PointArray.hs --- a/Game/LambdaHack/Common/PointArray.hs +++ b/Game/LambdaHack/Common/PointArray.hs @@ -1,22 +1,25 @@ -- | Arrays, based on Data.Vector.Unboxed, indexed by @Point@. module Game.LambdaHack.Common.PointArray ( GArray(..), Array, pindex, punindex - , (!), accessI, (//) + , (!), accessI, (//), unsafeUpdateA, unsafeWriteA, unsafeWriteManyA , replicateA, replicateMA, generateA, generateMA, unfoldrNA, sizeA , foldrA, foldrA', foldlA', ifoldrA, ifoldrA', ifoldlA', foldMA', ifoldMA' - , mapA, imapA, imapMA_ - , safeSetA, unsafeSetA, unsafeUpdateA, unsafeWriteA, unsafeWriteManyA + , mapA, imapA, imapMA_, safeSetA, unsafeSetA , minIndexA, minLastIndexA, minIndexesA, maxIndexA, maxLastIndexA, forceA , fromListA, toListA +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , cnv +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Control.Monad.ST.Strict -import Data.Binary -import Data.Vector.Binary () +import Control.Monad.ST.Strict +import Data.Binary +import Data.Vector.Binary () import qualified Data.Vector.Fusion.Bundle as Bundle import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U @@ -35,6 +38,17 @@ instance Show (GArray w c) where show a = "PointArray.Array with size " ++ show (sizeA a) +instance (U.Unbox w, Binary w) => Binary (GArray w c) where + put Array{..} = do + put axsize + put aysize + put avector + get = do + axsize <- get + aysize <- get + avector <- get + return $! Array{..} + -- | Arrays of, effectively, @Word8@, indexed by @Point@. type Array c = GArray Word8 c @@ -204,6 +218,14 @@ let v = U.imap (\n c -> cnv $ f (punindex axsize n) (cnv c)) avector in Array{avector = v, ..} +-- | Map monadically over an array (function applied to each element +-- and its index) and ignore the results. +imapMA_ :: (U.Unbox w, Enum w, Enum c, Monad m) + => (Point -> c -> m ()) -> GArray w c -> m () +{-# INLINE imapMA_ #-} +imapMA_ f Array{..} = + U.imapM_ (\n c -> f (punindex axsize n) (cnv c)) avector + -- | Set all elements to the given value, in place. unsafeSetA :: (U.Unbox w, Enum w, Enum c) => c -> GArray w c -> GArray w c {-# INLINE unsafeSetA #-} @@ -219,14 +241,6 @@ safeSetA c Array{..} = Array{avector = U.modify (\v -> VM.set v (cnv c)) avector, ..} --- | Map monadically over an array (function applied to each element --- and its index) and ignore the results. -imapMA_ :: (U.Unbox w, Enum w, Enum c, Monad m) - => (Point -> c -> m ()) -> GArray w c -> m () -{-# INLINE imapMA_ #-} -imapMA_ f Array{..} = - U.imapM_ (\n c -> f (punindex axsize n) (cnv c)) avector - -- | Yield the point coordinates of a minimum element of the array. -- The array may not be empty. minIndexA :: (U.Unbox w, Ord w) => GArray w c -> Point @@ -286,14 +300,3 @@ toListA :: (U.Unbox w, Enum w, Enum c) => GArray w c -> [c] {-# INLINE toListA #-} toListA Array{..} = map cnv $ U.toList avector - -instance (U.Unbox w, Binary w) => Binary (GArray w c) where - put Array{..} = do - put axsize - put aysize - put avector - get = do - axsize <- get - aysize <- get - avector <- get - return $! Array{..} diff --git a/Game/LambdaHack/Common/Prelude.hs b/Game/LambdaHack/Common/Prelude.hs --- a/Game/LambdaHack/Common/Prelude.hs +++ b/Game/LambdaHack/Common/Prelude.hs @@ -1,4 +1,4 @@ --- | Client monad for interacting with a human through UI. +-- | Custom Prelude, compatible across many GHC versions. module Game.LambdaHack.Common.Prelude ( module Prelude.Compat @@ -30,7 +30,7 @@ import Data.Text (Text) import qualified Data.Text as T (pack) -import NLP.Miniutter.English ((<+>)) +import NLP.Miniutter.English ((<+>)) -- | Show and pack the result. tshow :: Show a => a -> Text diff --git a/Game/LambdaHack/Common/Random.hs b/Game/LambdaHack/Common/Random.hs --- a/Game/LambdaHack/Common/Random.hs +++ b/Game/LambdaHack/Common/Random.hs @@ -10,6 +10,10 @@ , castDice, chanceDice, castDiceXY -- * Specialized monadic folds , foldrM, foldlM' +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , rollFreq +#endif ) where import Prelude () @@ -17,15 +21,14 @@ import Game.LambdaHack.Common.Prelude import qualified Control.Monad.Trans.State.Strict as St -import Data.Ratio +import Data.Ratio import qualified System.Random as R import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Frequency -import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Frequency +import Game.LambdaHack.Common.Misc -- | The monad of computations with random generator state. --- The lazy state monad is OK here: the state is small and regularly forced. type Rnd a = St.State R.StdGen a -- | Get a random object within a range with a uniform distribution. @@ -83,14 +86,7 @@ -- | Cast dice scaled with current level depth. -- Note that at the first level, the scaled dice are always ignored. castDice :: AbsDepth -> AbsDepth -> Dice.Dice -> Rnd Int -castDice (AbsDepth n) (AbsDepth depth) dice = do - let !_A = assert (n >= 0 && n <= depth - `blame` "invalid depth for dice rolls" - `swith` (n, depth)) () - dc <- frequency $ Dice.diceConst dice - dl <- frequency $ Dice.diceLevel dice - return $! (dc + (dl * max 0 (n - 1)) `div` max 1 (depth - 1)) - * Dice.diceMult dice +castDice = Dice.castDice randomR -- | Cast dice scaled with current level depth and return @True@ -- if the results is greater than 50. diff --git a/Game/LambdaHack/Common/ReqFailure.hs b/Game/LambdaHack/Common/ReqFailure.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Common/ReqFailure.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | Possible causes of failure of request. +module Game.LambdaHack.Common.ReqFailure + ( ReqFailure(..) + , impossibleReqFailure, showReqFailure + , permittedPrecious, permittedProject, permittedProjectAI, permittedApply +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , permittedPreciousAI +#endif + ) where + +import Prelude () + +import Game.LambdaHack.Common.Prelude + +import Data.Binary +import GHC.Generics (Generic) + +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.ItemStrongest +import Game.LambdaHack.Common.Time +import qualified Game.LambdaHack.Content.ItemKind as IK + +-- | Possible causes of failure of request. +data ReqFailure = + MoveNothing + | MeleeSelf + | MeleeDistant + | DisplaceDistant + | DisplaceAccess + | DisplaceProjectiles + | DisplaceDying + | DisplaceBraced + | DisplaceImmobile + | DisplaceSupported + | AlterUnskilled + | AlterUnwalked + | AlterDistant + | AlterBlockActor + | AlterBlockItem + | AlterNothing + | EqpOverfull + | EqpStackFull + | ApplyUnskilled + | ApplyRead + | ApplyOutOfReach + | ApplyCharging + | ApplyNoEffects + | ItemNothing + | ItemNotCalm + | NotCalmPrecious + | ProjectUnskilled + | ProjectAimOnself + | ProjectBlockTerrain + | ProjectBlockActor + | ProjectLobable + | ProjectOutOfReach + | TriggerNothing + | NoChangeDunLeader + deriving (Show, Eq, Generic) + +instance Binary ReqFailure + +impossibleReqFailure :: ReqFailure -> Bool +impossibleReqFailure reqFailure = case reqFailure of + MoveNothing -> True + MeleeSelf -> True + MeleeDistant -> True + DisplaceDistant -> True + DisplaceAccess -> True + DisplaceProjectiles -> True + DisplaceDying -> True + DisplaceBraced -> True + DisplaceImmobile -> False -- unidentified skill items + DisplaceSupported -> False + AlterUnskilled -> False -- unidentified skill items + AlterUnwalked -> False + AlterDistant -> True + AlterBlockActor -> True -- adjacent actor always visible + AlterBlockItem -> True -- adjacent item always visible + AlterNothing -> True + EqpOverfull -> True + EqpStackFull -> True + ApplyUnskilled -> False -- unidentified skill items + ApplyRead -> False -- unidentified skill items + ApplyOutOfReach -> True + ApplyCharging -> False -- if aspects unknown, charging unknown + ApplyNoEffects -> False -- if effects unknown, can't prevent it + ItemNothing -> True + ItemNotCalm -> False -- unidentified skill items + NotCalmPrecious -> False -- unidentified skill items + ProjectUnskilled -> False -- unidentified skill items + ProjectAimOnself -> True + ProjectBlockTerrain -> True -- adjacent terrain always visible + ProjectBlockActor -> True -- adjacent actor always visible + ProjectLobable -> False -- unidentified skill items + ProjectOutOfReach -> True + TriggerNothing -> True -- terrain underneath always visible + NoChangeDunLeader -> True + +showReqFailure :: ReqFailure -> Text +showReqFailure reqFailure = case reqFailure of + MoveNothing -> "wasting time on moving into obstacle" + MeleeSelf -> "trying to melee oneself" + MeleeDistant -> "trying to melee a distant foe" + DisplaceDistant -> "trying to displace a distant actor" + DisplaceAccess -> "switching places without access" + DisplaceProjectiles -> "trying to displace multiple projectiles" + DisplaceDying -> "trying to displace a dying foe" + DisplaceBraced -> "trying to displace a braced foe" + DisplaceImmobile -> "trying to displace an immobile foe" + DisplaceSupported -> "trying to displace a supported foe" + AlterUnskilled -> "unskilled actors cannot alter tiles" + AlterUnwalked -> "unskilled actors cannot enter tiles" + AlterDistant -> "trying to alter a distant tile" + AlterBlockActor -> "blocked by an actor" + AlterBlockItem -> "jammed by an item" + AlterNothing -> "wasting time on altering nothing" + EqpOverfull -> "cannot equip any more items" + EqpStackFull -> "cannot equip the whole item stack" + ApplyUnskilled -> "unskilled actors cannot apply items" + ApplyRead -> "activating this kind of items requires skill level 2" + ApplyOutOfReach -> "cannot apply an item out of reach" + ApplyCharging -> "cannot apply an item that is still charging" + ApplyNoEffects -> "cannot apply an item that produces no effects" + ItemNothing -> "wasting time on void item manipulation" + ItemNotCalm -> "you are too alarmed to use the shared stash" + NotCalmPrecious -> "you are too alarmed to handle such an exquisite item" + ProjectUnskilled -> "unskilled actors cannot aim" + ProjectAimOnself -> "cannot aim at oneself" + ProjectBlockTerrain -> "aiming obstructed by terrain" + ProjectBlockActor -> "aiming blocked by an actor" + ProjectLobable -> "lobbing an item requires fling skill 3" + ProjectOutOfReach -> "cannot aim an item out of reach" + TriggerNothing -> "wasting time on triggering nothing" + NoChangeDunLeader -> "no manual level change for your team" + +-- The item should not be applied nor thrown because it's too delicate +-- to operate when not calm or becuse it's too precious to identify by use. +permittedPrecious :: Bool -> Bool -> ItemFull -> Either ReqFailure Bool +permittedPrecious calmE forced itemFull = + let isPrecious = IK.Precious `elem` jfeature (itemBase itemFull) + in if not calmE && not forced && isPrecious then Left NotCalmPrecious + else Right $ IK.Durable `elem` jfeature (itemBase itemFull) + || case itemDisco itemFull of + Just ItemDisco{itemAspect=Just _} -> True + _ -> not isPrecious + +permittedPreciousAI :: Bool -> ItemFull -> Bool +permittedPreciousAI calmE itemFull = + let isPrecious = IK.Precious `elem` jfeature (itemBase itemFull) + in if not calmE && isPrecious then False + else IK.Durable `elem` jfeature (itemBase itemFull) + || case itemDisco itemFull of + Just ItemDisco{itemAspect=Just _} -> True + _ -> not isPrecious + +permittedProject :: Bool -> Int -> Bool -> [Char] -> ItemFull + -> Either ReqFailure Bool +permittedProject forced skill calmE triggerSyms itemFull@ItemFull{itemBase} = + if | not forced && skill < 1 -> Left ProjectUnskilled + | not forced + && IK.Lobable `elem` jfeature itemBase + && skill < 3 -> Left ProjectLobable + | otherwise -> + let legal = permittedPrecious calmE forced itemFull + in case legal of + Left{} -> legal + Right False -> legal + Right True -> Right $ + if | null triggerSyms -> True + | ' ' `elem` triggerSyms -> + case strengthEqpSlot itemFull of + Just IK.EqpSlotLightSource -> True + Just _ -> False + Nothing -> not (goesIntoEqp itemBase) + | otherwise -> jsymbol itemBase `elem` triggerSyms + +-- Speedup. +permittedProjectAI :: Int -> Bool -> ItemFull -> Bool +permittedProjectAI skill calmE itemFull@ItemFull{itemBase} = + if | skill < 1 -> False + | IK.Lobable `elem` jfeature itemBase + && skill < 3 -> False + | otherwise -> permittedPreciousAI calmE itemFull + +permittedApply :: Time -> Int -> Bool-> [Char] -> ItemFull + -> Either ReqFailure Bool +permittedApply localTime skill calmE triggerSyms itemFull@ItemFull{..} = + if | skill < 1 -> Left ApplyUnskilled + | jsymbol itemBase == '?' && skill < 2 -> Left ApplyRead + -- We assume if the item has a timeout, all or most of interesting + -- effects are under Recharging, so no point activating if not recharged. + -- Note that if client doesn't know the timeout, here we leak the fact + -- that the item is still charging, but the client risks destruction + -- if the item is, in fact, recharged and is not durable + -- (very likely in case of jewellery), so it's OK (the message may be + -- somewhat alarming though). + | not $ hasCharge localTime itemFull -> Left ApplyCharging + | otherwise -> case itemDisco of + Just ItemDisco{itemKind} | null $ IK.ieffects itemKind -> + Left ApplyNoEffects + _ -> let legal = permittedPrecious calmE False itemFull + in case legal of + Left{} -> legal + Right False -> legal + Right True -> Right $ + if ' ' `elem` triggerSyms + then IK.Applicable `elem` jfeature itemBase + else jsymbol itemBase `elem` triggerSyms diff --git a/Game/LambdaHack/Common/Request.hs b/Game/LambdaHack/Common/Request.hs deleted file mode 100644 --- a/Game/LambdaHack/Common/Request.hs +++ /dev/null @@ -1,259 +0,0 @@ -{-# LANGUAGE DataKinds, DeriveGeneric, GADTs, KindSignatures, StandaloneDeriving - #-} --- | Abstract syntax of server commands. --- See --- . -module Game.LambdaHack.Common.Request - ( RequestAI, ReqAI(..), RequestUI, ReqUI(..) - , RequestTimed(..), RequestAnyAbility(..), ReqFailure(..) - , impossibleReqFailure, showReqFailure, timedToUI - , permittedPrecious, permittedProject, permittedProjectAI, permittedApply - ) where - -import Prelude () - -import Game.LambdaHack.Common.Prelude - -import Data.Binary -import GHC.Generics (Generic) - -import Game.LambdaHack.Common.Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemStrongest -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector -import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind - --- | Client-server requests sent by AI clients. -data ReqAI = - ReqAITimed RequestAnyAbility - | ReqAINop - deriving Show - -type RequestAI = (ReqAI, Maybe ActorId) - --- | Client-server requests sent by UI clients. -data ReqUI = - ReqUINop - | ReqUITimed RequestAnyAbility - | ReqUIGameRestart (GroupName ModeKind) Challenge - | ReqUIGameExit - | ReqUIGameSave - | ReqUITactic Tactic - | ReqUIAutomate - deriving Show - -type RequestUI = (ReqUI, Maybe ActorId) - -data RequestAnyAbility = forall a. RequestAnyAbility (RequestTimed a) - -deriving instance Show RequestAnyAbility - -timedToUI :: RequestTimed a -> ReqUI -timedToUI = ReqUITimed . RequestAnyAbility - --- | Client-server requests that take game time. Sent by both AI and UI clients. -data RequestTimed :: Ability -> * where - ReqMove :: Vector -> RequestTimed 'AbMove - ReqMelee :: ActorId -> ItemId -> CStore -> RequestTimed 'AbMelee - ReqDisplace :: ActorId -> RequestTimed 'AbDisplace - ReqAlter :: Point -> RequestTimed 'AbAlter - ReqWait :: RequestTimed 'AbWait - ReqWait10 :: RequestTimed 'AbWait - ReqMoveItems :: [(ItemId, Int, CStore, CStore)] -> RequestTimed 'AbMoveItem - ReqProject :: Point -> Int -> ItemId -> CStore -> RequestTimed 'AbProject - ReqApply :: ItemId -> CStore -> RequestTimed 'AbApply - -deriving instance Show (RequestTimed a) - -data ReqFailure = - MoveNothing - | MeleeSelf - | MeleeDistant - | DisplaceDistant - | DisplaceAccess - | DisplaceProjectiles - | DisplaceDying - | DisplaceBraced - | DisplaceImmobile - | DisplaceSupported - | AlterUnskilled - | AlterUnwalked - | AlterDistant - | AlterBlockActor - | AlterBlockItem - | AlterNothing - | EqpOverfull - | EqpStackFull - | ApplyUnskilled - | ApplyRead - | ApplyOutOfReach - | ApplyCharging - | ApplyNoEffects - | ItemNothing - | ItemNotCalm - | NotCalmPrecious - | ProjectUnskilled - | ProjectAimOnself - | ProjectBlockTerrain - | ProjectBlockActor - | ProjectLobable - | ProjectOutOfReach - | TriggerNothing - | NoChangeDunLeader - deriving (Show, Eq, Generic) - -instance Binary ReqFailure - -impossibleReqFailure :: ReqFailure -> Bool -impossibleReqFailure reqFailure = case reqFailure of - MoveNothing -> True - MeleeSelf -> True - MeleeDistant -> True - DisplaceDistant -> True - DisplaceAccess -> True - DisplaceProjectiles -> True - DisplaceDying -> True - DisplaceBraced -> True - DisplaceImmobile -> False -- unidentified skill items - DisplaceSupported -> False - AlterUnskilled -> False -- unidentified skill items - AlterUnwalked -> False - AlterDistant -> True - AlterBlockActor -> True -- adjacent actor always visible - AlterBlockItem -> True -- adjacent item always visible - AlterNothing -> True - EqpOverfull -> True - EqpStackFull -> True - ApplyUnskilled -> False -- unidentified skill items - ApplyRead -> False -- unidentified skill items - ApplyOutOfReach -> True - ApplyCharging -> False -- if aspects unknown, charging unknown - ApplyNoEffects -> False -- if effects unknown, can't prevent it - ItemNothing -> True - ItemNotCalm -> False -- unidentified skill items - NotCalmPrecious -> False -- unidentified skill items - ProjectUnskilled -> False -- unidentified skill items - ProjectAimOnself -> True - ProjectBlockTerrain -> True -- adjacent terrain always visible - ProjectBlockActor -> True -- adjacent actor always visible - ProjectLobable -> False -- unidentified skill items - ProjectOutOfReach -> True - TriggerNothing -> True -- terrain underneath always visible - NoChangeDunLeader -> True - -showReqFailure :: ReqFailure -> Text -showReqFailure reqFailure = case reqFailure of - MoveNothing -> "wasting time on moving into obstacle" - MeleeSelf -> "trying to melee oneself" - MeleeDistant -> "trying to melee a distant foe" - DisplaceDistant -> "trying to displace a distant actor" - DisplaceAccess -> "switching places without access" - DisplaceProjectiles -> "trying to displace multiple projectiles" - DisplaceDying -> "trying to displace a dying foe" - DisplaceBraced -> "trying to displace a braced foe" - DisplaceImmobile -> "trying to displace an immobile foe" - DisplaceSupported -> "trying to displace a supported foe" - AlterUnskilled -> "unskilled actors cannot alter tiles" - AlterUnwalked -> "unskilled actors cannot enter tiles" - AlterDistant -> "trying to alter a distant tile" - AlterBlockActor -> "blocked by an actor" - AlterBlockItem -> "jammed by an item" - AlterNothing -> "wasting time on altering nothing" - EqpOverfull -> "cannot equip any more items" - EqpStackFull -> "cannot equip the whole item stack" - ApplyUnskilled -> "unskilled actors cannot apply items" - ApplyRead -> "activating this kind of items requires skill level 2" - ApplyOutOfReach -> "cannot apply an item out of reach" - ApplyCharging -> "cannot apply an item that is still charging" - ApplyNoEffects -> "cannot apply an item that produces no effects" - ItemNothing -> "wasting time on void item manipulation" - ItemNotCalm -> "you are too alarmed to use the shared stash" - NotCalmPrecious -> "you are too alarmed to handle such an exquisite item" - ProjectUnskilled -> "unskilled actors cannot aim" - ProjectAimOnself -> "cannot aim at oneself" - ProjectBlockTerrain -> "aiming obstructed by terrain" - ProjectBlockActor -> "aiming blocked by an actor" - ProjectLobable -> "lobbing an item requires fling skill 3" - ProjectOutOfReach -> "cannot aim an item out of reach" - TriggerNothing -> "wasting time on triggering nothing" - NoChangeDunLeader -> "no manual level change for your team" - --- The item should not be applied nor thrown because it's too delicate --- to operate when not calm or becuse it's too precious to identify by use. -permittedPrecious :: Bool -> Bool -> ItemFull -> Either ReqFailure Bool -permittedPrecious calmE forced itemFull = - let isPrecious = IK.Precious `elem` jfeature (itemBase itemFull) - in if not calmE && not forced && isPrecious then Left NotCalmPrecious - else Right $ IK.Durable `elem` jfeature (itemBase itemFull) - || case itemDisco itemFull of - Just ItemDisco{itemAspect=Just _} -> True - _ -> not isPrecious - -permittedPreciousAI :: Bool -> ItemFull -> Bool -permittedPreciousAI calmE itemFull = - let isPrecious = IK.Precious `elem` jfeature (itemBase itemFull) - in if not calmE && isPrecious then False - else IK.Durable `elem` jfeature (itemBase itemFull) - || case itemDisco itemFull of - Just ItemDisco{itemAspect=Just _} -> True - _ -> not isPrecious - -permittedProject :: Bool -> Int -> Bool -> [Char] -> ItemFull - -> Either ReqFailure Bool -permittedProject forced skill calmE triggerSyms itemFull@ItemFull{itemBase} = - if | not forced && skill < 1 -> Left ProjectUnskilled - | not forced - && IK.Lobable `elem` jfeature itemBase - && skill < 3 -> Left ProjectLobable - | otherwise -> - let legal = permittedPrecious calmE forced itemFull - in case legal of - Left{} -> legal - Right False -> legal - Right True -> Right $ - if | null triggerSyms -> True - | ' ' `elem` triggerSyms -> - case strengthEqpSlot itemFull of - Just IK.EqpSlotLightSource -> True - Just _ -> False - Nothing -> not (goesIntoEqp itemBase) - | otherwise -> jsymbol itemBase `elem` triggerSyms - --- Speedup. -permittedProjectAI :: Int -> Bool -> ItemFull -> Bool -permittedProjectAI skill calmE itemFull@ItemFull{itemBase} = - if | skill < 1 -> False - | IK.Lobable `elem` jfeature itemBase - && skill < 3 -> False - | otherwise -> permittedPreciousAI calmE itemFull - -permittedApply :: Time -> Int -> Bool-> [Char] -> ItemFull - -> Either ReqFailure Bool -permittedApply localTime skill calmE triggerSyms itemFull@ItemFull{..} = - if | skill < 1 -> Left ApplyUnskilled - | jsymbol itemBase == '?' && skill < 2 -> Left ApplyRead - -- We assume if the item has a timeout, all or most of interesting - -- effects are under Recharging, so no point activating if not recharged. - -- Note that if client doesn't know the timeout, here we leak the fact - -- that the item is still charging, but the client risks destruction - -- if the item is, in fact, recharged and is not durable - -- (very likely in case of jewellery), so it's OK (the message may be - -- somewhat alarming though). - | not $ hasCharge localTime itemFull -> Left ApplyCharging - | otherwise -> case itemDisco of - Just ItemDisco{itemKind} | null $ IK.ieffects itemKind -> - Left ApplyNoEffects - _ -> let legal = permittedPrecious calmE False itemFull - in case legal of - Left{} -> legal - Right False -> legal - Right True -> Right $ - if ' ' `elem` triggerSyms - then IK.Applicable `elem` jfeature itemBase - else jsymbol itemBase `elem` triggerSyms diff --git a/Game/LambdaHack/Common/Response.hs b/Game/LambdaHack/Common/Response.hs deleted file mode 100644 --- a/Game/LambdaHack/Common/Response.hs +++ /dev/null @@ -1,33 +0,0 @@ --- | Abstract syntax of client commands. --- See --- . -module Game.LambdaHack.Common.Response - ( Response(..), CliSerQueue, ChanServer(..) - ) where - -import Prelude () - -import Game.LambdaHack.Common.Prelude - -import Control.Concurrent - -import Game.LambdaHack.Atomic -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.Request - --- | Abstract syntax of client commands for both AI and UI clients. -data Response = - RespUpdAtomic UpdAtomic - | RespQueryAI ActorId - | RespSfxAtomic SfxAtomic - | RespQueryUI - deriving Show - -type CliSerQueue = MVar - --- | Connection channel between the server and a single client. -data ChanServer = ChanServer - { responseS :: CliSerQueue Response - , requestAIS :: CliSerQueue RequestAI - , requestUIS :: Maybe (CliSerQueue RequestUI) - } diff --git a/Game/LambdaHack/Common/RingBuffer.hs b/Game/LambdaHack/Common/RingBuffer.hs --- a/Game/LambdaHack/Common/RingBuffer.hs +++ b/Game/LambdaHack/Common/RingBuffer.hs @@ -9,11 +9,12 @@ import Game.LambdaHack.Common.Prelude hiding (length, uncons) -import Data.Binary +import Data.Binary import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq -import GHC.Generics (Generic) +import GHC.Generics (Generic) +-- | Ring buffers of a size determined at initialization. data RingBuffer a = RingBuffer { rbCarrier :: Seq.Seq a , rbMaxSize :: Int @@ -30,7 +31,6 @@ let rbMaxSize = max 1 size in RingBuffer (Seq.replicate rbMaxSize dummy) rbMaxSize 0 0 --- | Add element to the front of the buffer. cons :: a -> RingBuffer a -> RingBuffer a cons a RingBuffer{..} = let incNext = (rbNext + 1) `mod` rbMaxSize diff --git a/Game/LambdaHack/Common/Save.hs b/Game/LambdaHack/Common/Save.hs --- a/Game/LambdaHack/Common/Save.hs +++ b/Game/LambdaHack/Common/Save.hs @@ -1,9 +1,9 @@ --- | Saving and restoring server game state. +-- | Saving and restoring game state, used by both server and clients. module Game.LambdaHack.Common.Save ( ChanSave, saveToChan, wrapInSaves, restoreGame, saveNameCli, saveNameSer #ifdef EXPOSE_INTERNAL -- * Internal operations - , loopSave + , loopSave, vExevLib, showVersion2, delayPrint #endif ) where @@ -14,22 +14,22 @@ -- Cabal import qualified Paths_LambdaHack as Self (version) -import Control.Concurrent -import Control.Concurrent.Async -import qualified Control.Exception as Ex hiding (handle) -import Data.Binary -import Data.Text (Text) +import Control.Concurrent +import Control.Concurrent.Async +import qualified Control.Exception as Ex +import Data.Binary +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Version -import System.FilePath -import System.IO (hFlush, stdout) +import Data.Version +import System.FilePath +import System.IO (hFlush, stdout) import qualified System.Random as R -import Game.LambdaHack.Common.File +import Game.LambdaHack.Common.File import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Misc (FactionId, appDataDir) -import Game.LambdaHack.Content.RuleKind +import Game.LambdaHack.Common.Misc (FactionId, appDataDir) +import Game.LambdaHack.Content.RuleKind type ChanSave a = MVar (Maybe a) @@ -39,7 +39,7 @@ void $ tryTakeMVar toSave putMVar toSave $ Just s --- | Repeatedly save a simple serialized version of the current state. +-- | Repeatedly save serialized snapshots of current state. loopSave :: Binary a => Kind.COps -> (a -> FilePath) -> ChanSave a -> IO () loopSave cops stateToFileName toSave = loop diff --git a/Game/LambdaHack/Common/State.hs b/Game/LambdaHack/Common/State.hs --- a/Game/LambdaHack/Common/State.hs +++ b/Game/LambdaHack/Common/State.hs @@ -1,56 +1,143 @@ --- | Server and client game state types and operations. +-- | The common server and client basic game state type and its operations. module Game.LambdaHack.Common.State ( -- * Basic game state, local or global State -- * State components - , sdungeon, stotalDepth, sactorD, sitemD, sfactionD, stime, scops, shigh, sgameModeId - -- * State operations + , sdungeon, stotalDepth, sactorD, sitemD, sitemIxMap, sfactionD, stime, scops + , shigh, sgameModeId, sdiscoKind, sdiscoAspect, sactorAspect + -- * State construction , defStateGlobal, emptyState, localFromGlobal - , updateDungeon, updateDepth, updateActorD, updateItemD + -- * State update + , updateDungeon, updateDepth, updateActorD, updateItemD, updateItemIxMap , updateFactionD, updateTime, updateCOps - ) where + , updateDiscoKind, updateDiscoAspect, updateActorAspect + -- * State operations + , getItemBody, aspectRecordFromItem, aspectRecordFromIid + , aspectRecordFromActor, actorAspectInDungeon +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , unknownLevel, unknownTileMap +#endif + ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.HighScore as HighScore -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.TileKind (TileKind, unknownId) +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.TileKind (TileKind, unknownId) --- | View on game state. "Remembered" fields carry a subset of the info --- in the client copies of the state. Clients never directly change --- their @State@, but apply atomic actions sent by the server to do so. +-- | View on the basic game state. +-- The @remembered@ fields, in client copies of the state, carry only +-- a subset of the full information that the server keeps. +-- Clients never directly change their @State@, but apply +-- atomic actions sent by the server to do so (and/or the server applies +-- the actions to each client state in turn). data State = State - { _sdungeon :: Dungeon -- ^ remembered dungeon - , _stotalDepth :: AbsDepth -- ^ absolute dungeon depth, for item creation - , _sactorD :: ActorDict -- ^ remembered actors in the dungeon - , _sitemD :: ItemDict -- ^ remembered items in the dungeon - , _sfactionD :: FactionDict -- ^ remembered sides still in game - , _stime :: Time -- ^ global game time, for UI display only - , _scops :: ~Kind.COps -- ^ remembered content - , _shigh :: HighScore.ScoreDict -- ^ high score table - , _sgameModeId :: Kind.Id ModeKind -- ^ current game mode + { _sdungeon :: Dungeon -- ^ remembered dungeon + , _stotalDepth :: AbsDepth -- ^ absolute dungeon depth, for item creation + , _sactorD :: ActorDict -- ^ remembered actors in the dungeon + , _sitemD :: ItemDict -- ^ remembered items in the dungeon + , _sitemIxMap :: ItemIxMap -- ^ spotted items with the same kind index + , _sfactionD :: FactionDict -- ^ remembered sides still in game + , _stime :: Time -- ^ global game time, for UI display only + , _scops :: ~Kind.COps -- ^ remembered content + , _shigh :: HighScore.ScoreDict -- ^ high score table + , _sgameModeId :: Kind.Id ModeKind -- ^ current game mode + , _sdiscoKind :: DiscoveryKind -- ^ item kind discoveries data + , _sdiscoAspect :: DiscoveryAspect -- ^ item aspect data + , _sactorAspect :: ActorAspect -- ^ actor aspect data } deriving (Show, Eq) +instance Binary State where + put State{..} = do + put _sdungeon + put _stotalDepth + put _sactorD + put _sitemD + put _sitemIxMap + put _sfactionD + put _stime + put _shigh + put _sgameModeId + put _sdiscoKind + put _sdiscoAspect + get = do + _sdungeon <- get + _stotalDepth <- get + _sactorD <- get + _sitemD <- get + _sitemIxMap <- get + _sfactionD <- get + _stime <- get + _shigh <- get + _sgameModeId <- get + _sdiscoKind <- get + _sdiscoAspect <- get + let _scops = error $ "overwritten by recreated cops" `showFailure` () + sNoActorAspect = State{_sactorAspect = EM.empty, ..} + _sactorAspect = actorAspectInDungeon sNoActorAspect + return $! State{..} + +sdungeon :: State -> Dungeon +sdungeon = _sdungeon + +stotalDepth :: State -> AbsDepth +stotalDepth = _stotalDepth + +sactorD :: State -> ActorDict +sactorD = _sactorD + +sitemD :: State -> ItemDict +sitemD = _sitemD + +sitemIxMap :: State -> ItemIxMap +sitemIxMap = _sitemIxMap + +sfactionD :: State -> FactionDict +sfactionD = _sfactionD + +stime :: State -> Time +stime = _stime + +scops :: State -> Kind.COps +scops = _scops + +shigh :: State -> HighScore.ScoreDict +shigh = _shigh + +sgameModeId :: State -> Kind.Id ModeKind +sgameModeId = _sgameModeId + +sdiscoKind :: State -> DiscoveryKind +sdiscoKind = _sdiscoKind + +sdiscoAspect :: State -> DiscoveryAspect +sdiscoAspect = _sdiscoAspect + +sactorAspect :: State -> ActorAspect +sactorAspect = _sactorAspect + unknownLevel :: Kind.COps -> AbsDepth -> X -> Y - -> Text -> ([Point], [Point]) -> Int -> [Point] -> Bool + -> Text -> Text -> ([Point], [Point]) -> Int -> [Point] -> Bool -> Level unknownLevel Kind.COps{cotile=Kind.Ops{ouniqGroup}} - ldepth lxsize lysize ldesc lstair lexplorable lescape lnight = + ldepth lxsize lysize lname ldesc + lstair lexplorable lescape lnight = let outerId = ouniqGroup "basic outer fence" in Level { ldepth , lfloor = EM.empty @@ -60,7 +147,6 @@ , lxsize , lysize , lsmell = EM.empty - , ldesc , lstair , lseen = 0 , lexplorable @@ -71,6 +157,8 @@ , litemFreq = [] , lescape , lnight + , lname + , ldesc } unknownTileMap :: Kind.Id TileKind -> Int -> Int -> TileMap @@ -85,13 +173,17 @@ -- | Initial complete global game state. defStateGlobal :: Dungeon -> AbsDepth -> FactionDict -> Kind.COps - -> HighScore.ScoreDict -> Kind.Id ModeKind + -> HighScore.ScoreDict -> Kind.Id ModeKind -> DiscoveryKind -> State -defStateGlobal _sdungeon _stotalDepth _sfactionD _scops _shigh _sgameModeId = +defStateGlobal _sdungeon _stotalDepth _sfactionD _scops _shigh _sgameModeId + _sdiscoKind = State { _sactorD = EM.empty , _sitemD = EM.empty + , _sitemIxMap = EM.empty , _stime = timeZero + , _sdiscoAspect = EM.empty + , _sactorAspect = EM.empty , .. } @@ -103,11 +195,15 @@ , _stotalDepth = AbsDepth 0 , _sactorD = EM.empty , _sitemD = EM.empty + , _sitemIxMap = EM.empty , _sfactionD = EM.empty , _stime = timeZero , _scops , _shigh = HighScore.empty , _sgameModeId = minBound -- the initial value is unused + , _sdiscoKind = EM.empty + , _sdiscoAspect = EM.empty + , _sactorAspect = EM.empty } -- | Local state created by removing secret information from global @@ -117,8 +213,8 @@ State { _sdungeon = EM.map (\Level{..} -> - unknownLevel _scops ldepth lxsize lysize ldesc lstair lexplorable - lescape lnight) + unknownLevel _scops ldepth lxsize lysize lname ldesc + lstair lexplorable lescape lnight) _sdungeon , .. } @@ -139,6 +235,10 @@ updateItemD :: (ItemDict -> ItemDict) -> State -> State updateItemD f s = s {_sitemD = f (_sitemD s)} +-- | Update the item kind index map. +updateItemIxMap :: (ItemIxMap -> ItemIxMap) -> State -> State +updateItemIxMap f s = s {_sitemIxMap = f (_sitemIxMap s)} + -- | Update faction data within state. updateFactionD :: (FactionDict -> FactionDict) -> State -> State updateFactionD f s = s {_sfactionD = f (_sfactionD s)} @@ -151,51 +251,35 @@ updateCOps :: (Kind.COps -> Kind.COps) -> State -> State updateCOps f s = s {_scops = f (_scops s)} -sdungeon :: State -> Dungeon -sdungeon = _sdungeon - -stotalDepth :: State -> AbsDepth -stotalDepth = _stotalDepth - -sactorD :: State -> ActorDict -sactorD = _sactorD +updateDiscoKind :: (DiscoveryKind -> DiscoveryKind) -> State -> State +updateDiscoKind f s = s {_sdiscoKind = f (_sdiscoKind s)} -sitemD :: State -> ItemDict -sitemD = _sitemD +updateDiscoAspect :: (DiscoveryAspect -> DiscoveryAspect) -> State -> State +updateDiscoAspect f s = s {_sdiscoAspect = f (_sdiscoAspect s)} -sfactionD :: State -> FactionDict -sfactionD = _sfactionD +updateActorAspect :: (ActorAspect -> ActorAspect) -> State -> State +updateActorAspect f s = s {_sactorAspect = f (_sactorAspect s)} -stime :: State -> Time -stime = _stime +getItemBody :: ItemId -> State -> Item +getItemBody iid s = sitemD s EM.! iid -scops :: State -> Kind.COps -scops = _scops +aspectRecordFromItem :: ItemId -> Item -> State -> AspectRecord +aspectRecordFromItem iid item s = + case EM.lookup iid (sdiscoAspect s) of + Just ar -> ar + Nothing -> case EM.lookup (jkindIx item) (sdiscoKind s) of + Just KindMean{kmMean} -> kmMean + Nothing -> emptyAspectRecord -shigh :: State -> HighScore.ScoreDict -shigh = _shigh +aspectRecordFromIid :: ItemId -> State -> AspectRecord +aspectRecordFromIid iid s = aspectRecordFromItem iid (getItemBody iid s) s -sgameModeId :: State -> Kind.Id ModeKind -sgameModeId = _sgameModeId +aspectRecordFromActor :: Actor -> State -> AspectRecord +aspectRecordFromActor b s = + let processIid (iid, (k, _)) = (aspectRecordFromIid iid s, k) + processBag ass = sumAspectRecord $ map processIid ass + in processBag $ EM.assocs (borgan b) ++ EM.assocs (beqp b) -instance Binary State where - put State{..} = do - put _sdungeon - put _stotalDepth - put _sactorD - put _sitemD - put _sfactionD - put _stime - put _shigh - put _sgameModeId - get = do - _sdungeon <- get - _stotalDepth <- get - _sactorD <- get - _sitemD <- get - _sfactionD <- get - _stime <- get - _shigh <- get - _sgameModeId <- get - let _scops = error $ "overwritten by recreated cops" `showFailure` () - return $! State{..} +actorAspectInDungeon :: State -> ActorAspect +actorAspectInDungeon s = + EM.map (`aspectRecordFromActor` s) $ sactorD s diff --git a/Game/LambdaHack/Common/Tile.hs b/Game/LambdaHack/Common/Tile.hs --- a/Game/LambdaHack/Common/Tile.hs +++ b/Game/LambdaHack/Common/Tile.hs @@ -14,15 +14,19 @@ -- -- Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m). module Game.LambdaHack.Common.Tile - ( kindHasFeature, hasFeature, isClear, isLit, isWalkable, isDoor, isChangable + ( -- * Construction of tile property lookup speedup tables + speedup + -- * Sped up property lookups + , isClear, isLit, isWalkable, isDoor, isChangable , isSuspect, isHideAs, consideredByAI, isExplorable , isOftenItem, isOftenActor, isNoItem, isNoActor, isEasyOpen - , speedup, alterMinSkill, alterMinWalk - , openTo, closeTo, embeddedItems, revealAs, obscureAs, hideAs, buildAs - , isEasyOpenKind, isOpenable, isClosable + , alterMinSkill, alterMinWalk + -- * Slow property lookups + , kindHasFeature, hasFeature, openTo, closeTo, embeddedItems, revealAs + , obscureAs, hideAs, buildAs, isEasyOpenKind, isOpenable, isClosable #ifdef EXPOSE_INTERNAL -- * Internal operations - , createTab, createTabWithKey, accessTab + , createTab, createTabWithKey, accessTab, alterMinSkillKind, alterMinWalkKind #endif ) where @@ -31,14 +35,14 @@ import Game.LambdaHack.Common.Prelude import qualified Data.Vector.Unboxed as U -import Data.Word (Word8) +import Data.Word (Word8) import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Content.ItemKind (ItemKind) -import Game.LambdaHack.Content.TileKind (TileKind, TileSpeedup (..), - isUknownSpace) +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Content.TileKind (TileKind, TileSpeedup (..), + isUknownSpace) import qualified Game.LambdaHack.Content.TileKind as TK createTab :: U.Unbox a => Kind.Ops TileKind -> (TileKind -> a) -> TK.Tab a @@ -59,16 +63,77 @@ {-# INLINE accessTab #-} accessTab (TK.Tab tab) ki = tab `U.unsafeIndex` fromEnum ki --- | Whether a tile kind has the given feature. -kindHasFeature :: TK.Feature -> TileKind -> Bool -{-# INLINE kindHasFeature #-} -kindHasFeature f t = f `elem` TK.tfeature t +speedup :: Bool -> Kind.Ops TileKind -> TileSpeedup +speedup allClear cotile = + -- Vectors pack bools as Word8 by default. No idea if the extra memory + -- taken makes random lookups more or less efficient, so not optimizing + -- further, until I have benchmarks. + let isClearTab | allClear = createTab cotile + $ not . (== maxBound) . TK.talter + | otherwise = createTab cotile + $ kindHasFeature TK.Clear + isLitTab = createTab cotile $ not . kindHasFeature TK.Dark + isWalkableTab = createTab cotile $ kindHasFeature TK.Walkable + isDoorTab = createTab cotile $ \tk -> + let getTo TK.OpenTo{} = True + getTo TK.CloseTo{} = True + getTo _ = False + in any getTo $ TK.tfeature tk + isChangableTab = createTab cotile $ \tk -> + let getTo TK.ChangeTo{} = True + getTo _ = False + in any getTo $ TK.tfeature tk + isSuspectTab = createTab cotile TK.isSuspectKind + isHideAsTab = createTab cotile $ \tk -> + let getTo TK.HideAs{} = True + getTo _ = False + in any getTo $ TK.tfeature tk + consideredByAITab = createTab cotile $ kindHasFeature TK.ConsideredByAI + isOftenItemTab = createTab cotile $ kindHasFeature TK.OftenItem + isOftenActorTab = createTab cotile $ kindHasFeature TK.OftenActor + isNoItemTab = createTab cotile $ kindHasFeature TK.NoItem + isNoActorTab = createTab cotile $ kindHasFeature TK.NoActor + isEasyOpenTab = createTab cotile isEasyOpenKind + alterMinSkillTab = createTabWithKey cotile alterMinSkillKind + alterMinWalkTab = createTabWithKey cotile alterMinWalkKind + in TileSpeedup {..} --- | Whether a tile kind (specified by its id) has the given feature. -hasFeature :: Kind.Ops TileKind -> TK.Feature -> Kind.Id TileKind -> Bool -{-# INLINE hasFeature #-} -hasFeature Kind.Ops{okind} f t = kindHasFeature f (okind t) +-- Check that alter can be used, if not, @maxBound@. +-- For now, we assume only items with @Embed@ may have embedded items, +-- whether inserted at dungeon creation or later on. +-- This is used by UI and server to validate (sensibility of) altering. +-- See the comment for @alterMinWalkKind@ regarding @HideAs@. +alterMinSkillKind :: Kind.Id TileKind -> TileKind -> Word8 +alterMinSkillKind _k tk = + let getTo TK.OpenTo{} = True + getTo TK.CloseTo{} = True + getTo TK.ChangeTo{} = True + getTo TK.HideAs{} = True -- in case tile swapped, but server sends hidden + getTo TK.RevealAs{} = True + getTo TK.ObscureAs{} = True + getTo TK.Embed{} = True + getTo TK.ConsideredByAI = True + getTo _ = False + in if any getTo $ TK.tfeature tk then TK.talter tk else maxBound +-- How high alter skill is needed to make it walkable. If already +-- walkable, put @0@, if can't, put @maxBound@. Used only be AI and Bfs +-- We don't include @HideAs@, because it's very unlikely anybody swapped +-- the tile while AI was not looking so AI can assume it's still uninteresting. +-- Pathfinding in UI will also not show such tile as passable, which is OK. +-- If a human player has a suspicion the tile was swapped, he can check +-- it manually, disregarding the displayed path hints. +alterMinWalkKind :: Kind.Id TileKind -> TileKind -> Word8 +alterMinWalkKind k tk = + let getTo TK.OpenTo{} = True + getTo TK.RevealAs{} = True + getTo TK.ObscureAs{} = True + getTo _ = False + in if | kindHasFeature TK.Walkable tk -> 0 + | isUknownSpace k -> TK.talter tk + | any getTo $ TK.tfeature tk -> TK.talter tk + | otherwise -> maxBound + -- | Whether a tile does not block vision. -- Essential for efficiency of "FOV", hence tabulated. isClear :: TileSpeedup -> Kind.Id TileKind -> Bool @@ -112,11 +177,23 @@ {-# INLINE consideredByAI #-} consideredByAI TileSpeedup{consideredByAITab} = accessTab consideredByAITab +-- | Whether one can easily explore a tile, possibly finding a treasure, +-- either spawned there or dropped there by a (dying from poison) foe. +-- Doors can't be explorable since revealing a secret tile +-- should not change it's (walkable and) explorable status. +-- Door status should not depend on whether they are open or not +-- so that a foe opening a door doesn't force us to backtrack to explore it. +-- Still, a foe that digs through a wall will affect our exploration counter +-- and if content lets walls contain threasure, such backtraking makes sense. +isExplorable :: TileSpeedup -> Kind.Id TileKind -> Bool +isExplorable coTileSpeedup t = + isWalkable coTileSpeedup t && not (isDoor coTileSpeedup t) + isOftenItem :: TileSpeedup -> Kind.Id TileKind -> Bool {-# INLINE isOftenItem #-} isOftenItem TileSpeedup{isOftenItemTab} = accessTab isOftenItemTab -isOftenActor:: TileSpeedup -> Kind.Id TileKind -> Bool +isOftenActor :: TileSpeedup -> Kind.Id TileKind -> Bool {-# INLINE isOftenActor #-} isOftenActor TileSpeedup{isOftenActorTab} = accessTab isOftenActorTab @@ -144,88 +221,15 @@ alterMinWalk TileSpeedup{alterMinWalkTab} = fromEnum . accessTab alterMinWalkTab --- | Whether one can easily explore a tile, possibly finding a treasure, --- either spawned there or dropped there by a (dying from poison) foe. --- Doors can't be explorable since revealing a secret tile --- should not change it's (walkable and) explorable status. --- Door status should not depend on whether they are open or not --- so that a foe opening a door doesn't force us to backtrack to explore it. --- Still, a foe that digs through a wall will affect our exploration counter --- and if content lets walls contain threasure, such backtraking makes sense. -isExplorable :: TileSpeedup -> Kind.Id TileKind -> Bool -isExplorable coTileSpeedup t = - isWalkable coTileSpeedup t && not (isDoor coTileSpeedup t) - -speedup :: Bool -> Kind.Ops TileKind -> TileSpeedup -speedup allClear cotile = - -- Vectors pack bools as Word8 by default. No idea if the extra memory - -- taken makes random lookups more or less efficient, so not optimizing - -- further, until I have benchmarks. - let isClearTab | allClear = createTab cotile - $ not . (== maxBound) . TK.talter - | otherwise = createTab cotile - $ kindHasFeature TK.Clear - isLitTab = createTab cotile $ not . kindHasFeature TK.Dark - isWalkableTab = createTab cotile $ kindHasFeature TK.Walkable - isDoorTab = createTab cotile $ \tk -> - let getTo TK.OpenTo{} = True - getTo TK.CloseTo{} = True - getTo _ = False - in any getTo $ TK.tfeature tk - isChangableTab = createTab cotile $ \tk -> - let getTo TK.ChangeTo{} = True - getTo _ = False - in any getTo $ TK.tfeature tk - isSuspectTab = createTab cotile TK.isSuspectKind - isHideAsTab = createTab cotile $ \tk -> - let getTo TK.HideAs{} = True - getTo _ = False - in any getTo $ TK.tfeature tk - consideredByAITab = createTab cotile $ kindHasFeature TK.ConsideredByAI - isOftenItemTab = createTab cotile $ kindHasFeature TK.OftenItem - isOftenActorTab = createTab cotile $ kindHasFeature TK.OftenActor - isNoItemTab = createTab cotile $ kindHasFeature TK.NoItem - isNoActorTab = createTab cotile $ kindHasFeature TK.NoActor - isEasyOpenTab = createTab cotile isEasyOpenKind - alterMinSkillTab = createTabWithKey cotile alterMinSkillKind - alterMinWalkTab = createTabWithKey cotile alterMinWalkKind - in TileSpeedup {..} - --- Check that alter can be used, if not, @maxBound@. --- For now, we assume only items with @Embed@ may have embedded items, --- whether inserted at dungeon creation or later on. --- This is used by UI and server to validate (sensibility of) altering. --- See the comment for @alterMinWalkKind@ regarding @HideAs@. -alterMinSkillKind :: Kind.Id TileKind -> TileKind -> Word8 -alterMinSkillKind _k tk = - let getTo TK.OpenTo{} = True - getTo TK.CloseTo{} = True - getTo TK.ChangeTo{} = True - getTo TK.HideAs{} = True -- in case tile swapped, but server sends hidden - getTo TK.RevealAs{} = True - getTo TK.ObscureAs{} = True - getTo TK.Embed{} = True - getTo TK.ConsideredByAI = True - getTo _ = False - in if any getTo $ TK.tfeature tk then TK.talter tk else maxBound +-- | Whether a tile kind has the given feature. +kindHasFeature :: TK.Feature -> TileKind -> Bool +{-# INLINE kindHasFeature #-} +kindHasFeature f t = f `elem` TK.tfeature t --- How high alter skill is needed to make it walkable. If already --- walkable, put @0@, if can't, put @maxBound@. Used only be AI and Bfs --- We don't include @HideAs@, because it's very unlikely anybody swapped --- the tile while AI was not looking so AI can assume it's still uninteresting. --- Pathfinding in UI will also not show such tile as passable, which is OK. --- If a human player has a suspicion the tile was swapped, he can check --- it manually, disregarding the displayed path hints. -alterMinWalkKind :: Kind.Id TileKind -> TileKind -> Word8 -alterMinWalkKind k tk = - let getTo TK.OpenTo{} = True - getTo TK.RevealAs{} = True - getTo TK.ObscureAs{} = True - getTo _ = False - in if | kindHasFeature TK.Walkable tk -> 0 - | isUknownSpace k -> TK.talter tk - | any getTo $ TK.tfeature tk -> TK.talter tk - | otherwise -> maxBound +-- | Whether a tile kind (specified by its id) has the given feature. +hasFeature :: Kind.Ops TileKind -> TK.Feature -> Kind.Id TileKind -> Bool +{-# INLINE hasFeature #-} +hasFeature Kind.Ops{okind} f t = kindHasFeature f (okind t) openTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) openTo Kind.Ops{okind, opick} t = do @@ -245,7 +249,7 @@ embeddedItems :: Kind.Ops TileKind -> Kind.Id TileKind -> [GroupName ItemKind] embeddedItems Kind.Ops{okind} t = - let getTo (TK.Embed eff) acc = eff : acc + let getTo (TK.Embed igrp) acc = igrp : acc getTo _ acc = acc in foldr getTo [] $ TK.tfeature $ okind t @@ -269,13 +273,15 @@ grp <- oneOf groups fromMaybe (error $ "" `showFailure` grp) <$> opick grp (const True) -hideAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind +hideAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Maybe (Kind.Id TileKind) hideAs Kind.Ops{okind, ouniqGroup} t = let getTo TK.HideAs{} = True getTo _ = False in case find getTo $ TK.tfeature $ okind t of - Just (TK.HideAs grp) -> ouniqGroup grp - _ -> t + Just (TK.HideAs grp) -> + let tHidden = ouniqGroup grp + in assert (tHidden /= t) $ Just tHidden + _ -> Nothing buildAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind buildAs Kind.Ops{okind, ouniqGroup} t = diff --git a/Game/LambdaHack/Common/Time.hs b/Game/LambdaHack/Common/Time.hs --- a/Game/LambdaHack/Common/Time.hs +++ b/Game/LambdaHack/Common/Time.hs @@ -1,25 +1,29 @@ {-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-} -- | Game time and speed. module Game.LambdaHack.Common.Time - ( Time, timeZero, timeClip, timeTurn, timeSecond, timeEpsilon + ( Time, timeZero, timeEpsilon, timeClip, timeTurn, timeSecond , absoluteTimeAdd, absoluteTimeSubtract, absoluteTimeNegate , timeFit, timeFitUp , Delta(..), timeShift, timeDeltaToFrom , timeDeltaSubtract, timeDeltaReverse, timeDeltaScale, timeDeltaPercent - , timeDeltaToDigit, ticksPerMeter + , timeDeltaDiv, timeDeltaToDigit , Speed, toSpeed, fromSpeed , speedZero, speedWalk, speedLimp, speedThrust, modifyDamageBySpeed - , speedScale, timeDeltaDiv, speedAdd, speedNegate - , speedFromWeight, rangeFromSpeedAndLinger + , speedScale, speedAdd, speedNegate + , ticksPerMeter, speedFromWeight, rangeFromSpeedAndLinger +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , _timeTick, turnsInSecond, sInMs, minimalSpeed, rangeFromSpeed +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.Char as Char -import Data.Int (Int64) +import Data.Int (Int64) -- | Game time in ticks. The time dimension. -- One tick is 1 microsecond (one millionth of a second), @@ -27,17 +31,12 @@ newtype Time = Time {timeTicks :: Int64} deriving (Show, Eq, Ord, Enum, Bounded, Binary) --- | One-dimentional vectors. Introduced to tell apart the 2 uses of Time: --- as an absolute game time and as an increment. -newtype Delta a = Delta a - deriving (Show, Eq, Ord, Enum, Bounded, Binary, Functor) - -- | Start of the game time, or zero lenght time interval. timeZero :: Time timeZero = Time 0 --- | The smallest unit of time. Do not export, because the proportion --- of turn to tick is an implementation detail. +-- | The smallest unit of time. Should not be exported and used elsewhere, +-- because the proportion of turn to tick is an implementation detail. -- The significance of this detail is only that it determines resolution -- of the time dimension. _timeTick :: Time @@ -77,10 +76,11 @@ {-# INLINE absoluteTimeSubtract #-} absoluteTimeSubtract (Time t1) (Time t2) = Time (t1 - t2) --- | Shifting an absolute time by a time vector. -timeShift :: Time -> Delta Time -> Time -{-# INLINE timeShift #-} -timeShift (Time t1) (Delta (Time t2)) = Time (t1 + t2) +-- | Absolute time negation. To be used for reversing time flow, +-- e.g., for comparing absolute times in the reverse order. +absoluteTimeNegate :: Time -> Time +{-# INLINE absoluteTimeNegate #-} +absoluteTimeNegate (Time t) = Time (-t) -- | How many time intervals of the latter kind fits in an interval -- of the former kind. @@ -94,16 +94,15 @@ {-# INLINE timeFitUp #-} timeFitUp (Time t1) (Time t2) = fromEnum $ t1 `divUp` t2 --- | Reverse a time vector. -timeDeltaReverse :: Delta Time -> Delta Time -{-# INLINE timeDeltaReverse #-} -timeDeltaReverse (Delta (Time t)) = Delta (Time (-t)) +-- | One-dimentional vectors. Introduced to tell apart the 2 uses of Time: +-- as an absolute game time and as an increment. +newtype Delta a = Delta a + deriving (Show, Eq, Ord, Enum, Bounded, Binary, Functor) --- | Absolute time negation. To be used for reversing time flow, --- e.g., for comparing absolute times in the reverse order. -absoluteTimeNegate :: Time -> Time -{-# INLINE absoluteTimeNegate #-} -absoluteTimeNegate (Time t) = Time (-t) +-- | Shifting an absolute time by a time vector. +timeShift :: Time -> Delta Time -> Time +{-# INLINE timeShift #-} +timeShift (Time t1) (Delta (Time t2)) = Time (t1 + t2) -- | Time time vector between the second and the first absolute times. -- The arguments are in the same order as in the underlying scalar subtraction. @@ -117,6 +116,11 @@ {-# INLINE timeDeltaSubtract #-} timeDeltaSubtract (Delta (Time t1)) (Delta (Time t2)) = Delta $ Time (t1 - t2) +-- | Reverse a time vector. +timeDeltaReverse :: Delta Time -> Delta Time +{-# INLINE timeDeltaReverse #-} +timeDeltaReverse (Delta (Time t)) = Delta (Time (-t)) + -- | Scale the time vector by an @Int@ scalar value. timeDeltaScale :: Delta Time -> Int -> Delta Time {-# INLINE timeDeltaScale #-} @@ -162,15 +166,15 @@ {-# INLINE toSpeed #-} toSpeed s = Speed $ fromIntegral s * sInMs `div` 10 --- Can't be lower or actors would slow down (via tmp organs and weight), --- boost time with InsertMove, speed up and have lots of free moves. -minimalSpeed :: Int64 -minimalSpeed = sInMs `div` 10 - -- | Pretty-printing of speed in the format used in content definitions. fromSpeed :: Speed -> Int {-# INLINE fromSpeed #-} fromSpeed (Speed s) = fromEnum $ s * 10 `div` sInMs + +-- Can't be lower or actors would slow down (via tmp organs and weight), +-- boost time with InsertMove, speed up and have lots of free moves. +minimalSpeed :: Int64 +minimalSpeed = sInMs `div` 10 -- | No movement possible at that speed. speedZero :: Speed diff --git a/Game/LambdaHack/Common/Vector.hs b/Game/LambdaHack/Common/Vector.hs --- a/Game/LambdaHack/Common/Vector.hs +++ b/Game/LambdaHack/Common/Vector.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} --- | Basic operations on 2D vectors represented in an efficient, --- but not unique, way. +-- | Basic operations on bounded 2D vectors, with an efficient, but not 1-1 +-- and not monotonic @Enum@ instance. module Game.LambdaHack.Common.Vector ( Vector(..), isUnit, isDiagonal, neg, chessDistVector, euclidDistSqVector , moves, movesCardinal, movesDiagonal, compassText @@ -9,17 +9,21 @@ , shift, shiftBounded, trajectoryToPath, trajectoryToPathBounded , vectorToFrom, pathToTrajectory , RadianAngle, rotate, towards +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , maxVectorDim, _moveTexts, longMoveTexts, normalize, normalizeVector +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Control.DeepSeq -import Data.Binary +import Control.DeepSeq +import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Int (Int32) +import Data.Int (Int32) import GHC.Generics (Generic) @@ -73,17 +77,17 @@ {-# INLINE neg #-} neg (Vector vx vy) = Vector (-vx) (-vy) --- | Squared euclidean distance between two vectors. -euclidDistSqVector :: Vector -> Vector -> Int -euclidDistSqVector (Vector x0 y0) (Vector x1 y1) = - (x1 - x0) ^ (2 :: Int) + (y1 - y0) ^ (2 :: Int) - -- | The lenght of a vector in the chessboard metric, -- where diagonal moves cost 1. chessDistVector :: Vector -> Int {-# INLINE chessDistVector #-} chessDistVector (Vector x y) = max (abs x) (abs y) +-- | Squared euclidean distance between two vectors. +euclidDistSqVector :: Vector -> Vector -> Int +euclidDistSqVector (Vector x0 y0) (Vector x1 y1) = + (x1 - x0) ^ (2 :: Int) + (y1 - y0) ^ (2 :: Int) + -- | Vectors of all unit moves in the chessboard metric, -- clockwise, starting north-west. moves :: [Vector] @@ -91,6 +95,15 @@ map (uncurry Vector) [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)] +-- | Vectors of all cardinal direction unit moves, clockwise, starting north. +movesCardinal :: [Vector] +movesCardinal = map (uncurry Vector) [(0, -1), (1, 0), (0, 1), (-1, 0)] + +-- | Vectors of all diagonal direction unit moves, clockwise, starting north. +movesDiagonal :: [Vector] +movesDiagonal = map (uncurry Vector) [(-1, -1), (1, -1), (1, 1), (-1, 1)] + +-- | Currently unused. _moveTexts :: [Text] _moveTexts = ["NW", "N", "NE", "E", "SE", "S", "SW", "W"] @@ -102,14 +115,6 @@ compassText v = let m = EM.fromList $ zip moves longMoveTexts assFail = error $ "not a unit vector" `showFailure` v in EM.findWithDefault assFail v m - --- | Vectors of all cardinal direction unit moves, clockwise, starting north. -movesCardinal :: [Vector] -movesCardinal = map (uncurry Vector) [(0, -1), (1, 0), (0, 1), (-1, 0)] - --- | Vectors of all diagonal direction unit moves, clockwise, starting north. -movesDiagonal :: [Vector] -movesDiagonal = map (uncurry Vector) [(-1, -1), (1, -1), (1, 1), (-1, 1)] -- | All (8 at most) closest neighbours of a point within an area. vicinity :: X -> Y -- ^ limit the search to this area diff --git a/Game/LambdaHack/Content/CaveKind.hs b/Game/LambdaHack/Content/CaveKind.hs --- a/Game/LambdaHack/Content/CaveKind.hs +++ b/Game/LambdaHack/Content/CaveKind.hs @@ -1,4 +1,4 @@ --- | The type of cave layout kinds. +-- | The type of cave kinds. module Game.LambdaHack.Content.CaveKind ( CaveKind(..), validateSingleCaveKind, validateAllCaveKind ) where @@ -10,41 +10,42 @@ import qualified Data.Text as T import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Content.ItemKind (ItemKind) -import Game.LambdaHack.Content.PlaceKind -import Game.LambdaHack.Content.TileKind (TileKind) +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Content.PlaceKind +import Game.LambdaHack.Content.TileKind (TileKind) -- | Parameters for the generation of dungeon levels. -- Warning: for efficiency, avoid embedded items in any of the common tiles. data CaveKind = CaveKind - { csymbol :: Char -- ^ a symbol - , cname :: Text -- ^ short description - , cfreq :: Freqs CaveKind -- ^ frequency within groups - , cxsize :: X -- ^ X size of the whole cave - , cysize :: Y -- ^ Y size of the whole cave - , cgrid :: Dice.DiceXY -- ^ the dimensions of the grid of places - , cminPlaceSize :: Dice.DiceXY -- ^ minimal size of places; for merging - , cmaxPlaceSize :: Dice.DiceXY -- ^ maximal size of places - , cdarkChance :: Dice.Dice -- ^ the chance a place is dark - , cnightChance :: Dice.Dice -- ^ the chance the cave is dark - , cauxConnects :: Rational -- ^ a proportion of extra connections - , cmaxVoid :: Rational -- ^ at most this proportion of rooms void - , cminStairDist :: Int -- ^ minimal distance between stairs - , cextraStairs :: Dice.Dice -- ^ extra stairs on top of from above - , 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 - , cactorCoeff :: Int -- ^ the lower, the more monsters spawn - , cactorFreq :: Freqs ItemKind -- ^ actor groups to consider - , citemNum :: Dice.Dice -- ^ the number of items in the cave - , citemFreq :: Freqs ItemKind - -- ^ item groups to consider - , cplaceFreq :: Freqs PlaceKind - -- ^ place groups to consider - , cpassable :: Bool -- ^ are passable default tiles permitted + { csymbol :: Char -- ^ a symbol + , cname :: Text -- ^ short description + , cfreq :: Freqs CaveKind -- ^ frequency within groups + , cxsize :: X -- ^ X size of the whole cave + , cysize :: Y -- ^ Y size of the whole cave + , cgrid :: Dice.DiceXY + -- ^ the dimensions of the grid of places + , cminPlaceSize :: Dice.DiceXY -- ^ minimal size of places; for merging + , cmaxPlaceSize :: Dice.DiceXY -- ^ maximal size of places + , cdarkChance :: Dice.Dice -- ^ the chance a place is dark + , cnightChance :: Dice.Dice -- ^ the chance the cave is dark + , cauxConnects :: Rational -- ^ a proportion of extra connections + , cmaxVoid :: Rational + -- ^ at most this proportion of rooms may be void + , cminStairDist :: Int -- ^ minimal distance between stairs + , cextraStairs :: Dice.Dice -- ^ extra stairs on top of from above + , 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 + , cactorCoeff :: Int -- ^ the lower, the more monsters spawn + , cactorFreq :: Freqs ItemKind -- ^ actor groups to consider + , citemNum :: Dice.Dice -- ^ the number of items in the cave + , citemFreq :: Freqs ItemKind -- ^ item groups to consider + , cplaceFreq :: Freqs PlaceKind -- ^ place groups to consider + , cpassable :: Bool + -- ^ are passable default tiles permitted , cdefTile :: GroupName TileKind -- ^ the default cave tile , cdarkCorTile :: GroupName TileKind -- ^ the dark cave corridor tile , clitCorTile :: GroupName TileKind -- ^ the lit cave corridor tile @@ -56,6 +57,7 @@ , cstairFreq :: Freqs PlaceKind -- ^ place groups to consider for stairs; in this case the rarity -- of items in the group does not affect group choice + , cdesc :: Text -- ^ cave description } deriving Show -- No Eq and Ord to make extending it logically sound @@ -83,10 +85,10 @@ | maxGridX * (maxMinSizeX - 4) + xborder >= cxsize ] ++ [ "cysize too small" | maxGridY * maxMinSizeY + yborder >= cysize ] - ++ [ "cextraStairs < 0" | cextraStairs < 0 ] + ++ [ "cextraStairs < 0" | Dice.minDice cextraStairs < 0 ] ++ [ "chidden < 0" | chidden < 0 ] ++ [ "cactorCoeff < 0" | cactorCoeff < 0 ] - ++ [ "citemNum < 0" | citemNum < 0 ] + ++ [ "citemNum < 0" | Dice.minDice citemNum < 0 ] -- | Validate all cave kinds. -- Note that names don't have to be unique: we can have several variants diff --git a/Game/LambdaHack/Content/ItemKind.hs b/Game/LambdaHack/Content/ItemKind.hs --- a/Game/LambdaHack/Content/ItemKind.hs +++ b/Game/LambdaHack/Content/ItemKind.hs @@ -1,92 +1,106 @@ {-# LANGUAGE DeriveGeneric #-} --- | The type of kinds of weapons, treasure, organs, blasts and actors. +-- | The type of kinds of weapons, treasure, organs, blasts, etc. module Game.LambdaHack.Content.ItemKind ( ItemKind(..) , Effect(..), TimerDice(..) , Aspect(..), ThrowMod(..) , Feature(..), EqpSlot(..) - , forApplyEffect, forIdEffect + , boostItemKindList, forApplyEffect, forIdEffect , toDmg, toVelocity, toLinger, toOrganGameTurn, toOrganActorTurn, toOrganNone , validateSingleItemKind, validateAllItemKind +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , boostItemKind, validateDups, validateDamage, hardwiredItemGroups +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Control.DeepSeq -import Data.Binary -import Data.Hashable (Hashable) +import Control.DeepSeq +import Data.Binary +import Data.Hashable (Hashable) import qualified Data.Set as S import qualified Data.Text as T -import GHC.Generics (Generic) +import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU +import qualified System.Random as R import qualified Game.LambdaHack.Common.Ability as Ability import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Flavour -import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Flavour +import Game.LambdaHack.Common.Misc -- | Item properties that are fixed for a given kind of items. data ItemKind = ItemKind - { isymbol :: Char -- ^ map symbol - , iname :: Text -- ^ generic name - , ifreq :: Freqs ItemKind -- ^ frequency within groups - , iflavour :: [Flavour] -- ^ possible flavours - , icount :: Dice.Dice -- ^ created in that quantity - , irarity :: Rarity -- ^ rarity on given depths - , iverbHit :: MU.Part -- ^ the verb&noun for applying and hit - , iweight :: Int -- ^ weight in grams + { isymbol :: Char -- ^ map symbol + , iname :: Text -- ^ generic name + , ifreq :: Freqs ItemKind -- ^ frequency within groups + , iflavour :: [Flavour] -- ^ possible flavours + , icount :: Dice.Dice -- ^ created in that quantity + , irarity :: Rarity -- ^ rarity on given depths + , iverbHit :: MU.Part -- ^ the verb&noun for applying and hit + , iweight :: Int -- ^ weight in grams , idamage :: [(Int, Dice.Dice)] -- ^ frequency of basic impact damage - , iaspects :: [Aspect] -- ^ keep the aspect continuously - , ieffects :: [Effect] -- ^ cause the effect when triggered - , ifeature :: [Feature] -- ^ public properties - , idesc :: Text -- ^ description + , iaspects :: [Aspect] -- ^ keep the aspect continuously + , ieffects :: [Effect] -- ^ cause the effect when triggered + , ifeature :: [Feature] -- ^ public properties + , idesc :: Text -- ^ description , ikit :: [(GroupName ItemKind, CStore)] - -- ^ accompanying organs and items + -- ^ accompanying organs and items } deriving Show -- No Eq and Ord to make extending it logically sound -- | Effects of items. Can be invoked by the item wielder to affect -- another actor or the wielder himself. Many occurences in the same item --- are possible. Constructors are sorted vs increasing impact/danger. +-- are possible. data Effect = - -- Ordinary effects. - ELabel Text -- ^ secret (learned as effect) label of the item + ELabel Text -- ^ secret (learned as effect) name of the item | EqpSlot EqpSlot -- ^ AI and UI flag that leaks item properties - | Burn Dice.Dice + | Burn Dice.Dice -- ^ burn with this damage | Explode (GroupName ItemKind) - -- ^ explode, producing this group of blasts - | RefillHP Int - | RefillCalm Int - | Dominate - | Impress + -- ^ explode producing this group of blasts + | RefillHP Int -- ^ modify HP of the actor by this amount + | RefillCalm Int -- ^ modify Calm of the actor by this amount + | Dominate -- ^ change actor's allegiance + | Impress -- ^ make actor susceptible to domination | Summon (GroupName ItemKind) Dice.Dice - | Ascend Bool - | Escape - | Paralyze Dice.Dice -- ^ expressed in game clips - | InsertMove Dice.Dice -- ^ expressed in game turns - | Teleport Dice.Dice + -- ^ summon the given number of actors of this group + | Ascend Bool -- ^ ascend to another level of the dungeon + | Escape -- ^ escape from the dungeon + | Paralyze Dice.Dice -- ^ paralyze for this many game clips + | InsertMove Dice.Dice -- ^ give free time to actor of this many game turns + | Teleport Dice.Dice -- ^ teleport actor across rougly this distance | CreateItem CStore (GroupName ItemKind) TimerDice -- ^ create an item of the group and insert into the store with the given -- random timer | DropItem Int Int CStore (GroupName ItemKind) + -- ^ make the actor drop items of the given group from the given store; + -- the first integer says how many item kinds to drop, the second, + -- how many copie of each kind to drop | PolyItem + -- ^ find a suitable (i.e., numerous enough) item, starting from + -- the floor, and polymorph it randomly | Identify - | Detect Int - | DetectActor Int - | DetectItem Int - | DetectExit Int - | DetectHidden Int - | SendFlying ThrowMod - | PushActor ThrowMod - | PullActor ThrowMod - | DropBestWeapon - | ActivateInv Char -- ^ symbol @' '@ means all - | ApplyPerfume - -- Exotic effects follow. - | OneOf [Effect] - | OnSmash Effect -- ^ trigger if item smashed (not applied nor meleed) + -- ^ find a suitable (i.e., not identified) item, starting from + -- the floor, and identify it + | Detect Int -- ^ detect all on the map in the given radius + | DetectActor Int -- ^ detect actors on the map in the given radius + | DetectItem Int -- ^ detect items on the map in the given radius + | DetectExit Int -- ^ detect exits on the map in the given radius + | DetectHidden Int -- ^ detect hidden tiles on the map in the radius + | SendFlying ThrowMod -- ^ send an actor flying (push or pull, depending) + | PushActor ThrowMod -- ^ push an actor + | PullActor ThrowMod -- ^ pull an actor + | DropBestWeapon -- ^ make the actor drop its best weapon + | ActivateInv Char + -- ^ activate all items with this symbol in inventory; space character + -- means all symbols + | ApplyPerfume -- ^ remove all smell on the level + | OneOf [Effect] -- ^ trigger one of the effects with equal probability + | OnSmash Effect + -- ^ trigger the effect when item smashed (not when applied nor meleed) | Recharging Effect -- ^ this effect inactive until timeout passes | Temporary Text -- ^ the item is temporary, vanishes at even void Periodic activation, @@ -94,36 +108,20 @@ -- this verb at last copy activation or at each activation -- unless Durable and Fragile | Unique -- ^ at most one copy can ever be generated - | Periodic -- ^ in eqp, triggered as often as @Timeout@ permits - deriving (Show, Eq, Ord, Generic) + | Periodic + -- ^ in equipment, triggered as often as @Timeout@ permits + | Composite [Effect] -- ^ only fire next effect if previous was triggered + deriving (Show, Eq, Generic) instance NFData Effect -forApplyEffect :: Effect -> Bool -forApplyEffect eff = case eff of - ELabel{} -> False - EqpSlot{} -> False - OnSmash{} -> False - Temporary{} -> False - Unique -> False - Periodic -> False - _ -> True - -forIdEffect :: Effect -> Bool -forIdEffect eff = case eff of - ELabel{} -> False - EqpSlot{} -> False - OnSmash{} -> False - Explode{} -> False -- tentative; needed for rings to auto-identify - Unique -> False - Periodic -> False - _ -> True - +-- | Specification of how to randomly roll a timer at item creation +-- to obtain a fixed timer for the item's lifetime. data TimerDice = TimerNone | TimerGameTurn Dice.Dice | TimerActorTurn Dice.Dice - deriving (Eq, Ord, Generic) + deriving (Eq, Generic) instance Show TimerDice where show TimerNone = "0" @@ -144,12 +142,12 @@ | AddArmorRanged Dice.Dice -- ^ percentage armor bonus against ranged | AddMaxHP Dice.Dice -- ^ maximal hp | AddMaxCalm Dice.Dice -- ^ maximal calm - | AddSpeed Dice.Dice -- ^ speed in m/10s (not of a projectile) - | AddSight Dice.Dice -- ^ FOV radius, where 1 means a single tile - | AddSmell Dice.Dice -- ^ smell radius, where 1 means a single tile - | AddShine Dice.Dice -- ^ shine radius, where 1 means a single tile - | AddNocto Dice.Dice -- ^ noctovision radius, where 1 is single tile - | AddAggression Dice.Dice -- ^ aggression, especially closing in for melee + | AddSpeed Dice.Dice -- ^ speed in m/10s (not when pushed or pulled) + | AddSight Dice.Dice -- ^ FOV radius, where 1 means a single tile FOV + | AddSmell Dice.Dice -- ^ smell radius + | AddShine Dice.Dice -- ^ shine radius + | AddNocto Dice.Dice -- ^ noctovision radius + | AddAggression Dice.Dice -- ^ aggression, e.g., when closing in for melee | AddAbility Ability.Ability Dice.Dice -- ^ bonus to an ability deriving (Show, Eq, Ord, Generic) @@ -163,8 +161,8 @@ instance NFData ThrowMod --- | Features of item. Affect only the item in question, not the actor, --- and so not additive in any sense. +-- | Features of item. Publicly visible. Affect only the item in question, +-- not the actor, and so not additive in any sense. data Feature = Fragile -- ^ drop and break at target tile, even if no hit | Lobable -- ^ drop at target tile, even if no hit @@ -173,13 +171,14 @@ | Identified -- ^ the item starts identified | Applicable -- ^ AI and UI flag: consider applying | Equipable -- ^ AI and UI flag: consider equipping (independent of - -- ^ 'EqpSlot', e.g., in case of mixed blessings) + -- 'EqpSlot', e.g., in case of mixed blessings) | Meleeable -- ^ AI and UI flag: consider meleeing with - | Precious -- ^ AI and UI flag: don't risk identifying by use - -- also, can't throw or apply if not calm enough; + | Precious -- ^ AI and UI flag: don't risk identifying by use; + -- also, can't throw or apply if not calm enough | Tactic Tactic -- ^ overrides actor's tactic deriving (Show, Eq, Ord, Generic) +-- | AI and UI hints about the role of the item. data EqpSlot = EqpSlotMiscBonus | EqpSlotAddHurtMelee @@ -232,6 +231,48 @@ instance Binary EqpSlot +boostItemKindList :: R.StdGen -> [ItemKind] -> [ItemKind] +boostItemKindList _ [] = [] +boostItemKindList initialGen l = + let (r, _) = R.randomR (0, length l - 1) initialGen + in case splitAt r l of + (pre, i : post) -> pre ++ boostItemKind i : post + _ -> error $ "" `showFailure` l + +boostItemKind :: ItemKind -> ItemKind +boostItemKind i = + let mainlineLabel (label, _) = label `elem` ["useful", "treasure"] + in if any mainlineLabel (ifreq i) + then i { ifreq = ("useful", 10000) + : filter (not . mainlineLabel) (ifreq i) + , ieffects = delete Unique $ ieffects i + } + else i + +-- | Whether the effect has a chance of exhibiting any potentially +-- noticeable behaviour. +forApplyEffect :: Effect -> Bool +forApplyEffect eff = case eff of + ELabel{} -> False + EqpSlot{} -> False + OnSmash{} -> False + Temporary{} -> False + Unique -> False + Periodic -> False + Composite effs -> any forApplyEffect effs + _ -> True + +forIdEffect :: Effect -> Bool +forIdEffect eff = case eff of + ELabel{} -> False + EqpSlot{} -> False + OnSmash{} -> False + Explode{} -> False -- tentative; needed for rings to auto-identify + Unique -> False + Periodic -> False + Composite (eff1 : _) -> forIdEffect eff1 -- the rest may never fire + _ -> True + toDmg :: Dice.Dice -> [(Int, Dice.Dice)] toDmg dmg = [(1, dmg)] @@ -254,7 +295,7 @@ validateSingleItemKind :: ItemKind -> [Text] validateSingleItemKind ik@ItemKind{..} = [ "iname longer than 23" | T.length iname > 23 ] - ++ [ "icount < 0" | icount < 0 ] + ++ [ "icount < 0" | Dice.minDice icount < 0 ] ++ validateRarity irarity ++ validateDamage idamage -- Reject duplicate Timeout, because it's not additive. diff --git a/Game/LambdaHack/Content/ModeKind.hs b/Game/LambdaHack/Content/ModeKind.hs --- a/Game/LambdaHack/Content/ModeKind.hs +++ b/Game/LambdaHack/Content/ModeKind.hs @@ -1,36 +1,41 @@ {-# LANGUAGE DeriveGeneric #-} -- | The type of kinds of game modes. module Game.LambdaHack.Content.ModeKind - ( Caves, Roster(..), Player(..), ModeKind(..), LeaderMode(..), AutoLeader(..) - , Outcome(..), HiIndeterminant(..), HiCondPoly, HiSummand, HiPolynomial + ( ModeKind(..), Caves, Roster(..), Outcome(..) + , HiCondPoly, HiSummand, HiPolynomial, HiIndeterminant(..) + , Player(..), LeaderMode(..), AutoLeader(..) , validateSingleModeKind, validateAllModeKind +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , validateSingleRoster, validateSinglePlayer, hardwiredModeGroups +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.IntMap.Strict as IM import qualified Data.Set as S import qualified Data.Text as T -import GHC.Generics (Generic) +import GHC.Generics (Generic) -import Game.LambdaHack.Common.Ability +import Game.LambdaHack.Common.Ability import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Content.CaveKind -import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Content.CaveKind +import Game.LambdaHack.Content.ItemKind (ItemKind) -- | Game mode specification. data ModeKind = ModeKind - { msymbol :: Char -- ^ a symbol - , mname :: Text -- ^ short description + { msymbol :: Char -- ^ a symbol + , mname :: Text -- ^ short description , mfreq :: Freqs ModeKind -- ^ frequency within groups - , mroster :: Roster -- ^ players taking part in the game - , mcaves :: Caves -- ^ arena of the game - , mdesc :: Text -- ^ description + , mroster :: Roster -- ^ players taking part in the game + , mcaves :: Caves -- ^ arena of the game + , mdesc :: Text -- ^ description } deriving Show @@ -47,7 +52,7 @@ , rosterEnemy :: [(Text, Text)] -- ^ the initial enmity matrix , rosterAlly :: [(Text, Text)] -- ^ the initial aliance matrix } - deriving (Show, Eq) + deriving Show -- | Outcome of a game. data Outcome = @@ -61,39 +66,39 @@ instance Binary Outcome -data HiIndeterminant = HiConst | HiLoot | HiBlitz | HiSurvival | HiKill | HiLoss - deriving (Show, Eq, Ord, Generic) +-- | Conditional polynomial representing score calculation for this player. +type HiCondPoly = [HiSummand] -instance Binary HiIndeterminant +type HiSummand = (HiPolynomial, [Outcome]) type HiPolynomial = [(HiIndeterminant, Double)] -type HiSummand = (HiPolynomial, [Outcome]) +data HiIndeterminant = HiConst | HiLoot | HiBlitz | HiSurvival | HiKill | HiLoss + deriving (Show, Eq, Ord, Generic) --- | Conditional polynomial representing score calculation for this player. -type HiCondPoly = [HiSummand] +instance Binary HiIndeterminant -- | Properties of a particular player. data Player = Player { fname :: Text -- ^ name of the player , fgroups :: [GroupName ItemKind] - -- ^ names of actor groups that may naturally - -- fall under player's control, e.g., upon - -- spawning or summoning + -- ^ names of actor groups that may naturally + -- fall under player's control, e.g., upon + -- spawning or summoning , fskillsOther :: Skills -- ^ fixed skill modifiers to the non-leader - -- actors; also summed with skills implied - -- by ftactic (which is not fixed) + -- actors; also summed with skills implied + -- by ftactic (which is not fixed) , fcanEscape :: Bool -- ^ the player can escape the dungeon , fneverEmpty :: Bool -- ^ the faction declared killed if no actors , fhiCondPoly :: HiCondPoly -- ^ score polynomial for the player , fhasGender :: Bool -- ^ whether actors have gender , ftactic :: Tactic -- ^ non-leaders behave according to this - -- tactic; can be changed during the game + -- tactic; can be changed during the game , fleaderMode :: LeaderMode -- ^ the mode of switching the leader , fhasUI :: Bool -- ^ does the faction have a UI client - -- (for control or passive observation) + -- (for control or passive observation) } - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Generic) instance Binary Player diff --git a/Game/LambdaHack/Content/RuleKind.hs b/Game/LambdaHack/Content/RuleKind.hs --- a/Game/LambdaHack/Content/RuleKind.hs +++ b/Game/LambdaHack/Content/RuleKind.hs @@ -13,13 +13,8 @@ -- | The type of game rule sets and assorted game data. -- --- For now the rules are immutable througout the game, so there is --- no type @Rule@ to hold any changing parameters, just @RuleKind@ --- for the fixed set. --- However, in the future, if the rules can get changed during gameplay --- based on data mining of player behaviour, we may add such a type --- and then @RuleKind@ will become just a starting template, analogously --- as for the other content. +-- In principle, it'se possible to have many rule sets +-- and switch between them during a game session or even a single game. data RuleKind = RuleKind { rsymbol :: Char -- ^ a symbol , rname :: Text -- ^ short description @@ -39,8 +34,7 @@ } -- | A dummy instance of the 'Show' class, to satisfy general requirments --- about content. We won't have many rule sets and they contain functions, --- so defining a proper instance is not practical. +-- about content. We won't don't expect to ever print out whole rule sets. instance Show RuleKind where show _ = "The game ruleset specification." diff --git a/Game/LambdaHack/Content/TileKind.hs b/Game/LambdaHack/Content/TileKind.hs --- a/Game/LambdaHack/Content/TileKind.hs +++ b/Game/LambdaHack/Content/TileKind.hs @@ -1,31 +1,35 @@ {-# LANGUAGE DeriveGeneric #-} -- | The type of kinds of terrain tiles. module Game.LambdaHack.Content.TileKind - ( TileKind(..), Feature(..) + ( TileKind(..), Feature(..), TileSpeedup(..), Tab(..) , validateSingleTileKind, validateAllTileKind, actionFeatures - , TileSpeedup(..), Tab(..), isUknownSpace, unknownId - , isSuspectKind, isOpenableKind, isClosableKind, talterForStairs, floorSymbol + , isUknownSpace, unknownId, isSuspectKind, isOpenableKind, isClosableKind + , talterForStairs, floorSymbol +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , validateDups, hardwiredTileGroups +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Control.DeepSeq -import Data.Binary +import Control.DeepSeq +import Data.Binary import qualified Data.Char as Char -import Data.Hashable +import Data.Hashable import qualified Data.IntSet as IS import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Vector.Unboxed as U -import GHC.Generics (Generic) +import GHC.Generics (Generic) -import Game.LambdaHack.Common.Color +import Game.LambdaHack.Common.Color import qualified Game.LambdaHack.Common.KindOps as KindOps -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Content.ItemKind (ItemKind) -- | The type of kinds of terrain tiles. See @Tile.hs@ for explanation -- of the absence of a corresponding type @Tile@ that would hold @@ -60,19 +64,15 @@ -- ^ alters tile, but does not change walkability | HideAs (GroupName TileKind) -- ^ when hidden, looks as the unique tile of the group - - -- The following three are only used in dungeon generation. | BuildAs (GroupName TileKind) -- ^ when generating, may be transformed to the unique tile of the group | RevealAs (GroupName TileKind) -- ^ when generating in opening, can be revealed to belong to the group | ObscureAs (GroupName TileKind) -- ^ when generating in solid wall, can be revealed to belong to the group - | Walkable -- ^ actors can walk through | Clear -- ^ actors can see through | Dark -- ^ is not lit with an ambient light - | OftenItem -- ^ initial items often generated there | OftenActor -- ^ initial actors often generated there | NoItem -- ^ no items ever generated there @@ -118,14 +118,6 @@ -- indexing. Also, in JS bool arrays are obviously not packed. newtype Tab a = Tab (U.Vector a) -- morally indexed by @Id a@ -isUknownSpace :: KindOps.Id TileKind -> Bool -{-# INLINE isUknownSpace #-} -isUknownSpace tt = KindOps.Id 0 == tt - -unknownId :: KindOps.Id TileKind -{-# INLINE unknownId #-} -unknownId = KindOps.Id 0 - -- | Validate a single tile kind. validateSingleTileKind :: TileKind -> [Text] validateSingleTileKind t@TileKind{..} = @@ -171,25 +163,6 @@ let ts = filter (== feat) tfeature in ["more than one" <+> tshow feat <+> "specification" | length ts > 1] -isSuspectKind :: TileKind -> Bool -isSuspectKind t = - let getTo RevealAs{} = True - getTo ObscureAs{} = True - getTo _ = False - in any getTo $ tfeature t - -isOpenableKind ::TileKind -> Bool -isOpenableKind t = - let getTo OpenTo{} = True - getTo _ = False - in any getTo $ tfeature t - -isClosableKind :: TileKind -> Bool -isClosableKind t = - let getTo CloseTo{} = True - getTo _ = False - in any getTo $ tfeature t - -- | Validate all tile kinds. -- -- If tiles look the same on the map (symbol and color), their substantial @@ -265,6 +238,33 @@ Trail -> Just feat -- doesn't affect tile behaviour, but important Spice -> Nothing in IS.fromList $ map hash $ mapMaybe f $ tfeature t + +isUknownSpace :: KindOps.Id TileKind -> Bool +{-# INLINE isUknownSpace #-} +isUknownSpace tt = KindOps.Id 0 == tt + +unknownId :: KindOps.Id TileKind +{-# INLINE unknownId #-} +unknownId = KindOps.Id 0 + +isSuspectKind :: TileKind -> Bool +isSuspectKind t = + let getTo RevealAs{} = True + getTo ObscureAs{} = True + getTo _ = False + in any getTo $ tfeature t + +isOpenableKind ::TileKind -> Bool +isOpenableKind t = + let getTo OpenTo{} = True + getTo _ = False + in any getTo $ tfeature t + +isClosableKind :: TileKind -> Bool +isClosableKind t = + let getTo CloseTo{} = True + getTo _ = False + in any getTo $ tfeature t talterForStairs :: Word8 talterForStairs = 3 diff --git a/Game/LambdaHack/SampleImplementation/SampleMonadClient.hs b/Game/LambdaHack/SampleImplementation/SampleMonadClient.hs --- a/Game/LambdaHack/SampleImplementation/SampleMonadClient.hs +++ b/Game/LambdaHack/SampleImplementation/SampleMonadClient.hs @@ -1,8 +1,6 @@ -{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} --- | The main game action monad type implementation. Just as any other +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | The implementation of our custom game client monads. Just as any other -- component of the library, this implementation can be substituted. --- This module should not be imported anywhere except in 'Action' --- to expose the executor to any code using the library. module Game.LambdaHack.SampleImplementation.SampleMonadClient ( executorCli #ifdef EXPOSE_INTERNAL @@ -15,34 +13,35 @@ import Game.LambdaHack.Common.Prelude -import Control.Concurrent +import Control.Concurrent import qualified Control.Monad.IO.Class as IO -import Control.Monad.Trans.State.Strict hiding (State) -import GHC.Generics (Generic) +import Control.Monad.Trans.State.Strict hiding (State) -import Game.LambdaHack.Atomic -import Game.LambdaHack.Client -import Game.LambdaHack.Client.HandleResponseM -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI -import Game.LambdaHack.Common.ClientOptions -import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Atomic (MonadStateWrite (..), putState) +import Game.LambdaHack.Client +import Game.LambdaHack.Client.ClientOptions +import Game.LambdaHack.Client.HandleAtomicM +import Game.LambdaHack.Client.HandleResponseM +import Game.LambdaHack.Client.LoopM +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI +import Game.LambdaHack.Client.UI.SessionUI +import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Response +import Game.LambdaHack.Common.MonadStateRead import qualified Game.LambdaHack.Common.Save as Save -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.State +import Game.LambdaHack.Server (ChanServer (..)) data CliState = CliState { cliState :: State -- ^ current global state , cliClient :: StateClient -- ^ current client state , cliSession :: Maybe SessionUI -- ^ UI state, empty for AI clients , cliDict :: ChanServer -- ^ this client connection information - , cliToSave :: Save.ChanSave (State, StateClient, Maybe SessionUI) + , cliToSave :: Save.ChanSave (StateClient, Maybe SessionUI) -- ^ connection to the save thread } - deriving Generic -- | Client state transformation monad. newtype CliImplementation a = CliImplementation @@ -71,18 +70,17 @@ instance MonadClientSetup CliImplementation where saveClient = CliImplementation $ do toSave <- gets cliToSave - s <- gets cliState cli <- gets cliClient msess <- gets cliSession - IO.liftIO $ Save.saveToChan toSave (s, cli, msess) + IO.liftIO $ Save.saveToChan toSave (cli, msess) restartClient = CliImplementation $ state $ \cliS -> case cliSession cliS of Just sess -> - let !newSess = (emptySessionUI (sconfig sess)) + let !newSess = (emptySessionUI (sUIOptions sess)) { schanF = schanF sess , sbinding = sbinding sess , shistory = shistory sess - , _sreport = _sreport sess + , _sreport = sreport sess , sstart = sstart sess , sgstart = sgstart sess , sallTime = sallTime sess @@ -117,27 +115,26 @@ mSession <- gets cliSession return $! isJust mSession --- | The game-state semantics of atomic commands --- as computed on the client. -instance MonadAtomic CliImplementation where +instance MonadClientAtomic CliImplementation where {-# INLINE execUpdAtomic #-} - execUpdAtomic = handleUpdAtomic - {-# INLINE execSfxAtomic #-} - execSfxAtomic _sfx = return () - {-# INLINE execSendPer #-} - execSendPer _ _ _ _ _ = return () + execUpdAtomic _ = return () -- handleUpdAtomic, until needed, save resources + -- Don't catch anything; assume exceptions impossible. + {-# INLINE execPutState #-} + execPutState = putState --- | Init the client, then run an action, with a given session, --- state and history, in the @IO@ monad. -executorCli :: KeyKind -> Config -> DebugModeCli +-- | Run the main client loop, with the given arguments and empty +-- initial states, in the @IO@ monad. +executorCli :: KeyKind -> UIOptions -> ClientOptions -> Kind.COps - -> Maybe SessionUI + -> Bool -> FactionId -> ChanServer -> IO () -executorCli copsClient sconfig sdebugMode cops cliSession fid cliDict = - let stateToFileName (_, cli, _) = - ssavePrefixCli (sdebugCli cli) <> Save.saveNameCli cops (sside cli) +executorCli copsClient sUIOptions clientOptions cops isUI fid cliDict = + let cliSession | isUI = Just $ emptySessionUI sUIOptions + | otherwise = Nothing + stateToFileName (cli, _) = + ssavePrefixCli (soptions cli) <> Save.saveNameCli cops (sside cli) totalState cliToSave = CliState { cliState = emptyState cops , cliClient = emptyStateClient fid @@ -145,6 +142,6 @@ , cliToSave , cliSession } - m = loopCli copsClient sconfig sdebugMode + m = loopCli copsClient sUIOptions clientOptions exe = evalStateT (runCliImplementation m) . totalState in Save.wrapInSaves cops stateToFileName exe diff --git a/Game/LambdaHack/SampleImplementation/SampleMonadServer.hs b/Game/LambdaHack/SampleImplementation/SampleMonadServer.hs --- a/Game/LambdaHack/SampleImplementation/SampleMonadServer.hs +++ b/Game/LambdaHack/SampleImplementation/SampleMonadServer.hs @@ -1,8 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | The main game action monad type implementation. Just as any other +-- | The implementation of our custom game server monads. Just as any other -- component of the library, this implementation can be substituted. --- This module should not be imported anywhere except in 'Action' --- to expose the executor to any code using the library. module Game.LambdaHack.SampleImplementation.SampleMonadServer ( executorSer #ifdef EXPOSE_INTERNAL @@ -15,33 +13,35 @@ import Game.LambdaHack.Common.Prelude -import Control.Concurrent +import Control.Concurrent import qualified Control.Exception as Ex import qualified Control.Monad.IO.Class as IO -import Control.Monad.Trans.State.Strict hiding (State) +import Control.Monad.Trans.State.Strict hiding (State) import qualified Data.EnumMap.Strict as EM import qualified Data.Text.IO as T -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath -import System.IO (hFlush, stdout) +import Options.Applicative (defaultPrefs, execParserPure, + handleParseResult) +import System.Exit (ExitCode (ExitSuccess)) +import System.FilePath +import System.IO (hFlush, stdout) -import Game.LambdaHack.Atomic -import Game.LambdaHack.Client -import Game.LambdaHack.Common.ClientOptions -import Game.LambdaHack.Common.File +import Game.LambdaHack.Atomic +import Game.LambdaHack.Client +import Game.LambdaHack.Common.File import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead import qualified Game.LambdaHack.Common.Save as Save -import Game.LambdaHack.Common.State -import Game.LambdaHack.Common.Thread -import Game.LambdaHack.SampleImplementation.SampleMonadClient (executorCli) -import Game.LambdaHack.Server -import Game.LambdaHack.Server.BroadcastAtomic -import Game.LambdaHack.Server.HandleAtomicM -import Game.LambdaHack.Server.MonadServer -import Game.LambdaHack.Server.ProtocolM -import Game.LambdaHack.Server.State +import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Thread +import Game.LambdaHack.SampleImplementation.SampleMonadClient (executorCli) +import Game.LambdaHack.Server +import Game.LambdaHack.Server.BroadcastAtomic +import Game.LambdaHack.Server.HandleAtomicM +import Game.LambdaHack.Server.MonadServer +import Game.LambdaHack.Server.ProtocolM +import Game.LambdaHack.Server.ServerOptions +import Game.LambdaHack.Server.State data SerState = SerState { serState :: State -- ^ current global state @@ -73,7 +73,7 @@ modifyServer f = SerImplementation $ state $ \serS -> let !newSerServer = f $ serServer serS in ((), serS {serServer = newSerServer}) - saveChanServer = SerImplementation $ gets serToSave + chanSaveServer = SerImplementation $ gets serToSave liftIO = SerImplementation . IO.liftIO instance MonadServerReadRequest SerImplementation where @@ -85,50 +85,89 @@ in ((), serS {serDict = newSerDict}) liftIO = SerImplementation . IO.liftIO --- | The game-state semantics of atomic commands --- as computed on the server. -instance MonadAtomic SerImplementation where - execUpdAtomic cmd = cmdAtomicSemSer cmd >> handleAndBroadcast (UpdAtomic cmd) - execSfxAtomic sfx = handleAndBroadcast (SfxAtomic sfx) +instance MonadServerAtomic SerImplementation where + execUpdAtomic cmd = do + oldState <- getState + (ps, atomicBroken, executedOnServer) <- handleCmdAtomicServer cmd + when executedOnServer $ cmdAtomicSemSer oldState cmd + handleAndBroadcast ps atomicBroken (UpdAtomic cmd) + execUpdAtomicSer cmd = SerImplementation $ StateT $ \cliS -> do + cliSNewOrE <- Ex.try + $ execStateT (runSerImplementation $ handleUpdAtomic cmd) + cliS + case cliSNewOrE of + Left AtomicFail{} -> return (False, cliS) + Right cliSNew -> + -- We know @cliSNew@ differs only in @serState@. + return (True, cliSNew) + execUpdAtomicFid fid cmd = SerImplementation $ StateT $ \cliS -> do + -- Don't catch anything; assume exceptions impossible. + let sFid = sclientStates (serServer cliS) EM.! fid + cliSNew <- execStateT (runSerImplementation $ handleUpdAtomic cmd) + cliS {serState = sFid} + -- We know @cliSNew@ differs only in @serState@. + let serServerNew = (serServer cliS) + {sclientStates = EM.insert fid (serState cliSNew) + $ sclientStates $ serServer cliS} + return $! ((), cliS {serServer = serServerNew}) + execUpdAtomicFidCatch fid cmd = SerImplementation $ StateT $ \cliS -> do + let sFid = sclientStates (serServer cliS) EM.! fid + cliSNewOrE <- Ex.try + $ execStateT (runSerImplementation $ handleUpdAtomic cmd) + cliS {serState = sFid} + case cliSNewOrE of + Left AtomicFail{} -> return (False, cliS) + Right cliSNew -> do + -- We know @cliSNew@ differs only in @serState@. + let serServerNew = (serServer cliS) + {sclientStates = EM.insert fid (serState cliSNew) + $ sclientStates $ serServer cliS} + return $! (True, cliS {serServer = serServerNew}) + execSfxAtomic sfx = do + ps <- posSfxAtomic sfx + handleAndBroadcast ps [] (SfxAtomic sfx) execSendPer = sendPer -- Don't inline this, to keep GHC hard work inside the library -- for easy access of code analysis tools. --- | Run an action in the @IO@ monad, with undefined state. -executorSer :: Kind.COps -> KeyKind -> DebugModeSer -> IO () -executorSer cops copsClient sdebugNxtCmdline = do +-- | Run the main server loop, with the given arguments and empty +-- initial states, in the @IO@ monad. +executorSer :: Kind.COps -> KeyKind -> ServerOptions -> IO () +executorSer cops copsClient soptionsNxtCmdline = do -- Parse UI client configuration file. -- It is reparsed at each start of the game executable. - sconfig <- mkConfig cops (sbenchmark $ sdebugCli sdebugNxtCmdline) - sdebugNxt <- case configCmdline sconfig of - [] -> return sdebugNxtCmdline - args -> return $! debugArgs args + let benchmark = sbenchmark $ sclientOptions soptionsNxtCmdline + sUIOptions <- mkUIOptions cops benchmark + soptionsNxt <- case uCmdline sUIOptions of + [] -> return soptionsNxtCmdline + args -> handleParseResult $ execParserPure defaultPrefs serverOptionsPI args -- Options for the clients modified with the configuration file. -- The client debug inside server debug only holds the client commandline -- options and is never updated with config options, etc. - let sdebugMode = applyConfigToDebug cops sconfig $ sdebugCli sdebugNxt + let clientOptions = applyUIOptions cops sUIOptions + $ sclientOptions soptionsNxt -- Partially applied main loop of the clients. - executorClient = executorCli copsClient sconfig sdebugMode cops + executorClient = executorCli copsClient sUIOptions clientOptions cops -- Wire together game content, the main loop of game clients -- and the game server loop. let stateToFileName (_, ser) = - ssavePrefixSer (sdebugSer ser) <> Save.saveNameSer cops + ssavePrefixSer (soptions ser) <> Save.saveNameSer cops totalState serToSave = SerState { serState = emptyState cops , serServer = emptyStateServer , serDict = EM.empty , serToSave } - m = loopSer sdebugNxt sconfig executorClient + m = loopSer soptionsNxt executorClient exe = evalStateT (runSerImplementation m) . totalState exeWithSaves = Save.wrapInSaves cops stateToFileName exe - defPrefix = ssavePrefixSer defDebugModeSer + defPrefix = ssavePrefixSer defServerOptions bkpOneSave name = do dataDir <- appDataDir let path bkp = dataDir "saves" bkp <> name b <- doesFileExist (path "") when b $ renameFile (path "") (path "bkp.") - bkpAllSaves = do + bkpAllSaves = if benchmark then return () else do T.hPutStrLn stdout "The game crashed, so savefiles are moved aside." bkpOneSave $ defPrefix <> Save.saveNameSer cops forM_ [-99..99] $ \n -> @@ -144,7 +183,7 @@ _ -> do Ex.uninterruptibleMask_ $ threadDelay 1000000 -- let clients report their errors and save - when (ssavePrefixSer sdebugNxt == defPrefix) bkpAllSaves + when (ssavePrefixSer soptionsNxt == defPrefix) bkpAllSaves hFlush stdout Ex.throwIO ex -- crash eventually, which kills clients ) diff --git a/Game/LambdaHack/Server.hs b/Game/LambdaHack/Server.hs --- a/Game/LambdaHack/Server.hs +++ b/Game/LambdaHack/Server.hs @@ -1,18 +1,22 @@ --- | Semantics of requests that are sent to the server. +-- | Semantics of requests that are sent by clients to the server, +-- in terms of game state changes and responses to be sent to the clients. -- -- See -- . module Game.LambdaHack.Server ( -- * Re-exported from "Game.LambdaHack.Server.LoopM" loopSer + -- * Re-exported from "Game.LambdaHack.Server.ProtocolM" + , ChanServer (..) -- * Re-exported from "Game.LambdaHack.Server.Commandline" - , debugArgs - -- * Re-exported from "Game.LambdaHack.Server.State" - , DebugModeSer(..) + , serverOptionsPI + -- * Re-exported from "Game.LambdaHack.Server.ServerOptions" + , ServerOptions(..) ) where import Prelude () -import Game.LambdaHack.Server.Commandline (debugArgs) +import Game.LambdaHack.Server.Commandline (serverOptionsPI) import Game.LambdaHack.Server.LoopM (loopSer) -import Game.LambdaHack.Server.State (DebugModeSer (..)) +import Game.LambdaHack.Server.ProtocolM +import Game.LambdaHack.Server.ServerOptions diff --git a/Game/LambdaHack/Server/BroadcastAtomic.hs b/Game/LambdaHack/Server/BroadcastAtomic.hs --- a/Game/LambdaHack/Server/BroadcastAtomic.hs +++ b/Game/LambdaHack/Server/BroadcastAtomic.hs @@ -1,11 +1,13 @@ +{-# LANGUAGE TupleSections #-} -- | Sending atomic commands to clients and executing them on the server. +-- -- See -- . module Game.LambdaHack.Server.BroadcastAtomic - ( handleAndBroadcast, sendPer + ( handleAndBroadcast, sendPer, handleCmdAtomicServer #ifdef EXPOSE_INTERNAL -- * Internal operations - , handleCmdAtomicServer, atomicRemember + , loudUpdAtomic, loudSfxAtomic, atomicForget, atomicRemember #endif ) where @@ -15,43 +17,46 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Key (mapWithKeyM_) +import Data.Key (mapWithKeyM_) -import Game.LambdaHack.Atomic -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Atomic +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Server.ItemM -import Game.LambdaHack.Server.MonadServer -import Game.LambdaHack.Server.ProtocolM -import Game.LambdaHack.Server.State +import Game.LambdaHack.Content.TileKind (isUknownSpace) +import Game.LambdaHack.Server.MonadServer +import Game.LambdaHack.Server.ProtocolM +import Game.LambdaHack.Server.ServerOptions +import Game.LambdaHack.Server.State --storeUndo :: MonadServer m => CmdAtomic -> m () --storeUndo _atomic = -- maybe skip (\a -> modifyServer $ \ser -> ser {sundo = a : sundo ser}) -- $ Nothing -- undoCmdAtomic atomic -handleCmdAtomicServer :: MonadStateWrite m => PosAtomic -> UpdAtomic -> m () -{-# INLINE handleCmdAtomicServer #-} -handleCmdAtomicServer posAtomic cmd = - when (seenAtomicSer posAtomic) $ --- Not implemented ATM: --- storeUndo atomic - handleUpdAtomic cmd +handleCmdAtomicServer :: MonadServerAtomic m + => UpdAtomic -> m (PosAtomic, [UpdAtomic], Bool) +handleCmdAtomicServer cmd = do + ps <- posUpdAtomic cmd + atomicBroken <- breakUpdAtomic cmd + executedOnServer <- if seenAtomicSer ps + then execUpdAtomicSer cmd + else return False + return (ps, atomicBroken, executedOnServer) -- | Send an atomic action to all clients that can see it. -handleAndBroadcast :: (MonadStateWrite m, MonadServerReadRequest m) - => CmdAtomic -> m () -handleAndBroadcast atomic = do +handleAndBroadcast :: (MonadServerAtomic m, MonadServerReadRequest m) + => PosAtomic -> [UpdAtomic] -> CmdAtomic -> m () +handleAndBroadcast ps atomicBroken atomic = do -- This is calculated in the server State before action (simulating -- current client State, because action has not been applied -- on the client yet). @@ -59,20 +64,7 @@ -- To get rid of breakUpdAtomic we'd need to send only Spot and Lose -- commands instead of Move and Displace (plus Sfx for Displace). -- So this only makes sense when we switch to sending state diffs. - (ps, atomicBroken, psBroken) <- - case atomic of - UpdAtomic cmd -> do - ps <- posUpdAtomic cmd - atomicBroken <- breakUpdAtomic cmd - psBroken <- mapM posUpdAtomic atomicBroken - -- Perform the action on the server. The only part that requires - -- @MonadStateWrite@ and modifies server State. - handleCmdAtomicServer ps cmd - return (ps, atomicBroken, psBroken) - SfxAtomic sfx -> do - ps <- posSfxAtomic sfx - return (ps, [], []) - knowEvents <- getsServer $ sknowEvents . sdebugSer + knowEvents <- getsServer $ sknowEvents . soptions sperFidOld <- getsServer sperFid -- Send some actions to the clients, one faction at a time. let sendAtomic fid (UpdAtomic cmd) = sendUpdate fid cmd @@ -80,7 +72,7 @@ breakSend lid fid fact perFidLid = do -- We take the new leader, from after cmd execution. let hear atomic2 = do - local <- case _gleader fact of + local <- case gleader fact of Nothing -> return True -- give leaderless factions some love Just leader -> do body <- getsState $ getActorBody leader @@ -94,6 +86,7 @@ send2 (cmd2, ps2) = when (seenAtomicCli knowEvents fid perFidLid ps2) $ sendUpdate fid cmd2 + psBroken <- mapM posUpdAtomic atomicBroken case psBroken of _ : _ -> mapM_ send2 $ zip atomicBroken psBroken [] -> hear atomic -- broken commands are never loud @@ -144,11 +137,11 @@ return $! SfxLoudUpd local <$> mcmd -- | Messages for some unseen sfx. -loudSfxAtomic :: MonadServer m => Bool -> SfxAtomic -> m (Maybe SfxMsg) +loudSfxAtomic :: MonadStateRead m => Bool -> SfxAtomic -> m (Maybe SfxMsg) loudSfxAtomic local cmd = case cmd of SfxStrike source _ iid cstore | local -> do - itemToF <- itemToFullServer + itemToF <- getsState itemToFull sb <- getsState $ getActorBody source bag <- getsState $ getBodyStoreBag sb cstore let kit = EM.findWithDefault (1, []) iid bag @@ -161,52 +154,120 @@ return $ Just $ SfxLoudSummon (bproj b) grp p _ -> return Nothing -sendPer :: MonadServerReadRequest m - => FactionId -> LevelId - -> Perception -> Perception -> Perception -> m () +sendPer :: (MonadServerAtomic m, MonadServerReadRequest m) + => FactionId -> LevelId -> Perception -> Perception -> Perception + -> m () {-# INLINE sendPer #-} sendPer fid lid outPer inPer perNew = do - sendUpdate fid $ UpdPerception lid outPer inPer - remember <- getsState $ atomicRemember lid inPer + sendUpdNoState fid $ UpdPerception lid outPer inPer + sClient <- getsServer $ (EM.! fid) . sclientStates + let forget = atomicForget fid lid outPer sClient + remember <- getsState $ atomicRemember lid inPer sClient let seenNew = seenAtomicCli False fid perNew psRem <- mapM posUpdAtomic remember -- Verify that we remember only currently seen things. let !_A = assert (allB seenNew psRem) () + mapM_ (sendUpdateCheck fid) forget mapM_ (sendUpdate fid) remember -atomicRemember :: LevelId -> Perception -> State -> [UpdAtomic] +-- Remembered items, map tiles and smells are not wiped out when they get +-- out of FOV. Clients remember them. Only actors are forgotten. +atomicForget :: FactionId -> LevelId -> Perception -> State + -> [UpdAtomic] +atomicForget side lid outPer sClient = + -- Wipe out actors that just became invisible due to changed FOV. + let outFov = totalVisible outPer + outPrio = concatMap (\p -> posToAssocs p lid sClient) $ ES.elems outFov + fActor (aid, b) = + -- We forget only currently invisible actors. Actors can be outside + -- perception, but still visible, if they belong to our faction, + -- e.g., if they teleport to outside of current perception + -- or if they have disabled senses. + if not (bproj b) && bfid b == side + then Nothing + else Just $ UpdLoseActor aid b $ getCarriedAssocs b sClient + -- this command always succeeds, the actor can be always removed, + -- because the actor is taken from the state + outActor = mapMaybe fActor outPrio + in outActor + +atomicRemember :: LevelId -> Perception -> State -> State -> [UpdAtomic] {-# INLINE atomicRemember #-} -atomicRemember lid inPer s = - -- No @UpdLoseItem@ is sent for items that became out of sight. - -- The client will create these atomic actions based on @outPer@, - -- if required. Any client that remembers out of sight items, OTOH, - -- will create atomic actions that forget remembered items - -- that are revealed not to be there any more (no @UpdSpotItem@ for them). - -- Similarly no @UpdLoseActor@, @UpdLoseTile@ nor @UpdLoseSmell@. - let inFov = ES.elems $ totalVisible inPer +atomicRemember lid inPer sClient s = + let Kind.COps{cotile, coTileSpeedup} = scops s + inFov = ES.elems $ totalVisible inPer lvl = sdungeon s EM.! lid - -- Actors. + -- Wipe out remembered items on tiles that now came into view + -- and spot items on these tiles. Optimized away, when items match. + lvlClient = sdungeon sClient EM.! lid + inContainer allow fc bagEM bagEMClient = + let f p = case (EM.lookup p bagEM, EM.lookup p bagEMClient) of + (Nothing, Nothing) -> [] -- most common, no items ever + (Just bag, Nothing) -> -- common, client unaware + let ais = map (\iid -> (iid, getItemBody iid s)) + (EM.keys bag) + in [UpdSpotItemBag (fc lid p) bag ais | allow p] + (Nothing, Just bagClient) -> -- uncommon, all items vanished + -- We don't check @allow@, because client sees items there, + -- so we assume he's aware of the tile enough to notice. + let aisClient = map (\iid -> (iid, getItemBody iid sClient)) + (EM.keys bagClient) + in [UpdLoseItemBag (fc lid p) bagClient aisClient] + (Just bag, Just bagClient) -> + -- We don't check @allow@, because client sees items there, + -- so we assume he's aware of the tile enough to see new items. + if bag == bagClient + then [] -- common, nothing has changed, so optimized + else -- uncommon, surprise; because it's rare, we send + -- whole bags and don't optimize by sending only delta + let aisClient = map (\iid -> (iid, getItemBody iid sClient)) + (EM.keys bagClient) + ais = map (\iid -> (iid, getItemBody iid s)) + (EM.keys bag) + in [ UpdLoseItemBag (fc lid p) bagClient aisClient + , UpdSpotItemBag (fc lid p) bag ais ] + in concatMap f inFov + inFloor = inContainer (const True) CFloor (lfloor lvl) (lfloor lvlClient) + -- Check that client may be shown embedded items, assuming he's not seeing + -- any at this position so far. If he's not shown now, the items will be + -- revealed via searching the tile later on. + -- This check is essential to prevent embedded items from leaking + -- tile identity. + allowEmbed p = not (Tile.isHideAs coTileSpeedup $ lvl `at` p) + || lvl `at` p == lvlClient `at` p + inEmbed = inContainer allowEmbed CEmbed (lembed lvl) (lembed lvlClient) + -- Spot tiles. + atomicTile = + -- We ignore the server resending us hidden versions of the tiles + -- (or resending us the same data we already got). + -- If the tiles are changed to other variants of the hidden tile, + -- we can still verify by searching. + let f p (loses1, spots1) = + let t = lvl `at` p + tHidden = fromMaybe t $ Tile.hideAs cotile t + tClient = lvlClient `at` p + in if tClient `elem` [t, tHidden] + then (loses1, spots1) + else ( if isUknownSpace tClient + then loses1 + else (p, tClient) : loses1 + , (p, tHidden) : spots1 ) -- send the hidden version + (loses, spots) = foldr f ([], []) inFov + in [UpdLoseTile lid loses | not $ null loses] + ++ [UpdSpotTile lid spots | not $ null spots] + -- Wipe out remembered smell on tiles that now came into smell Fov. + -- Smell radius is small, so we can just wipe and send all. + inSmellFov = ES.elems $ totalSmelled inPer + inSm = mapMaybe (\p -> (p,) <$> EM.lookup p (lsmell lvlClient)) inSmellFov + inSmell = if null inSm then [] else [UpdLoseSmell lid inSm] + -- Spot smells. + inSm2 = mapMaybe (\p -> (p,) <$> EM.lookup p (lsmell lvl)) inSmellFov + atomicSmell = if null inSm2 then [] else [UpdSpotSmell lid inSm2] + -- Actors come last to report the environment they land on. inAssocs = concatMap (\p -> posToAssocs p lid s) inFov + -- Here, the actor may be already visible, e.g., when teleporting, + -- so the exception is caught in @sendUpdate@ above. fActor (aid, b) = let ais = getCarriedAssocs b s in UpdSpotActor aid b ais inActor = map fActor inAssocs - -- Items. - pMaybe p = maybe Nothing (\x -> Just (p, x)) - inContainer fc itemFloor = - let inItem = mapMaybe (\p -> pMaybe p $ EM.lookup p itemFloor) inFov - fItem p (iid, kit) = - UpdSpotItem True iid (getItemBody iid s) kit (fc lid p) - fBag (p, bag) = map (fItem p) $ EM.assocs bag - in concatMap fBag inItem - inFloor = inContainer CFloor (lfloor lvl) - inEmbed = inContainer CEmbed (lembed lvl) - -- Tiles. - Kind.COps{cotile} = scops s - hideTile p = Tile.hideAs cotile $ lvl `at` p - inTileMap = map (\p -> (p, hideTile p)) inFov - atomicTile = if null inTileMap then [] else [UpdSpotTile lid inTileMap] - -- Smells. - inSmellFov = ES.elems $ totalSmelled inPer - inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl)) inSmellFov - atomicSmell = if null inSm then [] else [UpdSpotSmell lid inSm] - in atomicTile ++ inFloor ++ inEmbed ++ atomicSmell ++ inActor + in atomicTile ++ inFloor ++ inEmbed ++ inSmell ++ atomicSmell ++ inActor diff --git a/Game/LambdaHack/Server/Commandline.hs b/Game/LambdaHack/Server/Commandline.hs --- a/Game/LambdaHack/Server/Commandline.hs +++ b/Game/LambdaHack/Server/Commandline.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE ApplicativeDo #-} -- | Parsing of commandline arguments. module Game.LambdaHack.Server.Commandline - ( debugArgs + ( serverOptionsPI +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , serverOptionsP + -- other internal operations too numerous and changing, so not listed +#endif ) where import Prelude () @@ -8,163 +14,255 @@ import Game.LambdaHack.Common.Prelude import qualified Data.Text as T +import Options.Applicative +import qualified System.Random as R -import Game.LambdaHack.Common.ClientOptions +-- Dependence on ClientOptions is an anomaly. Instead, probably the raw +-- remaining commandline should be passed and parsed by the client to extract +-- client and ui options from and singnal an error if anything was left. + +import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Server.State +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Server.ServerOptions --- | Parse server debug parameters from commandline arguments. -debugArgs :: [String] -> DebugModeSer -debugArgs = - let breakPar s = let (params, args) = break ("-" `isPrefixOf`) s - in (unwords params, args) - usage = - [ "Configure debug options here, gameplay options in config.rules.ini." - , " --knowMap reveal map for all clients in the next game" - , " --knowEvents show all events in the next game (needs --knowMap)" - , " --knowItems auto-identify all items in the next game (needs --knowEvents)" - , " --sniffIn display all incoming commands on console " - , " --sniffOut display all outgoing commands on console " - , " --allClear let all map tiles be translucent" - , " --boostRandomItem pick a random item and make it very common" - , " --gameMode m start next game in the given mode" - , " --automateAll give control of all UI teams to computer" - , " --keepAutomated keep factions automated after game over" - , " --newGame n start a new game, overwriting the save file," - , " with difficulty for all UI players set to n" - , " --stopAfterSeconds n exit game session after around n seconds" - , " --stopAfterFrames n exit game session after around n frames" - , " --benchmark restrict file IO, print stats" - , " --setDungeonRng s set dungeon generation RNG seed to string s" - , " --setMainRng s set the main game RNG seed to string s" - , " --dumpInitRngs dump RNG states from the start of the game" - , " --dbgMsgSer let the server emit its internal debug messages" - , " --gtkFontFamily s use the given font family for the main game window in GTK" - , " --sdlFontFile s use the given font file for the main game window in SDL2" - , " --sdlTtfSizeAdd s enlarge map cells over scalable font max height in SDL2" - , " --sdlFonSizeAdd s enlarge map cells on top of .fon font max height in SDL2" - , " --fontSize s use the given font size for the main game window" - , " --noColorIsBold refrain from making some bright color characters bolder" - , " --maxFps n display at most n frames per second" - , " --disableAutoYes never auto-answer all prompts" - , " --noAnim don't show any animations" - , " --savePrefix prepend the text to all savefile names" - , " --frontendTeletype use the line terminal frontend (for tests)" - , " --frontendNull use frontend with no display (for benchmarks)" - , " --frontendLazy use frontend that not even computes frames (for benchmarks)" - , " --dbgMsgCli let clients emit their internal debug messages" - ] - parseArgs [] = defDebugModeSer - parseArgs ("--knowMap" : rest) = - (parseArgs rest) {sknowMap = True} - parseArgs ("--knowEvents" : rest) = - (parseArgs rest) {sknowEvents = True} - parseArgs ("--knowItems" : rest) = - (parseArgs rest) {sknowItems = True} - parseArgs ("--sniffIn" : rest) = - (parseArgs rest) {sniffIn = True} - parseArgs ("--sniffOut" : rest) = - (parseArgs rest) {sniffOut = True} - parseArgs ("--allClear" : rest) = - (parseArgs rest) {sallClear = True} - parseArgs ("--boostRandomItem" : rest) = - (parseArgs rest) {sboostRandomItem = True} - parseArgs ("--gameMode" : rest) = - let (params, args) = breakPar rest - in (parseArgs args) {sgameMode = Just $ toGroupName (T.pack params)} - parseArgs ("--automateAll" : rest) = - (parseArgs rest) {sautomateAll = True} - parseArgs ("--keepAutomated" : rest) = - (parseArgs rest) {skeepAutomated = True} - parseArgs ("--newGame" : rest) = - let (params, args) = breakPar rest - debugSer = parseArgs args - cdiff = read params - in debugSer { scurChalSer = (scurChalSer debugSer) {cdiff} - , snewGameSer = True - , sdebugCli = (sdebugCli debugSer) {snewGameCli = True}} - parseArgs ("--stopAfterSeconds" : rest) = - let (params, args) = breakPar rest - debugSer = parseArgs args - in debugSer {sdebugCli = - (sdebugCli debugSer) {sstopAfterSeconds = Just $ read params}} - parseArgs ("--stopAfterFrames" : rest) = - let (params, args) = breakPar rest - debugSer = parseArgs args - in debugSer {sdebugCli = - (sdebugCli debugSer) {sstopAfterFrames = Just $ read params}} - parseArgs ("--benchmark" : rest) = - let debugSer = parseArgs rest - in debugSer {sdebugCli = (sdebugCli debugSer) {sbenchmark = True}} - parseArgs ("--setDungeonRng" : rest) = - let (params, args) = breakPar rest - in (parseArgs args) {sdungeonRng = Just $ read params} - parseArgs ("--setMainRng" : rest) = - let (params, args) = breakPar rest - in (parseArgs args) {smainRng = Just $ read params} - parseArgs ("--dumpInitRngs" : rest) = - (parseArgs rest) {sdumpInitRngs = True} - parseArgs ("--dbgMsgSer" : rest) = - (parseArgs rest) {sdbgMsgSer = True} - parseArgs ("--gtkFontFamily" : rest) = - let (params, args) = breakPar rest - debugSer = parseArgs args - in debugSer {sdebugCli = (sdebugCli debugSer) {sgtkFontFamily = - Just $ T.pack params}} - parseArgs ("--sdlFontFile" : rest) = - let (params, args) = breakPar rest - debugSer = parseArgs args - in debugSer {sdebugCli = (sdebugCli debugSer) {sdlFontFile = - Just $ T.pack params}} - parseArgs ("--sdlTtfSizeAdd" : rest) = - let (params, args) = breakPar rest - debugSer = parseArgs args - in debugSer {sdebugCli = (sdebugCli debugSer) {sdlTtfSizeAdd = - Just $ read params}} - parseArgs ("--sdlFonSizeAdd" : rest) = - let (params, args) = breakPar rest - debugSer = parseArgs args - in debugSer {sdebugCli = (sdebugCli debugSer) {sdlFonSizeAdd = - Just $ read params}} - parseArgs ("--fontSize" : rest) = - let (params, args) = breakPar rest - debugSer = parseArgs args - in debugSer {sdebugCli = (sdebugCli debugSer) {sfontSize = - Just $ read params}} - parseArgs ("--noColorIsBold" : rest) = - let debugSer = parseArgs rest - in debugSer {sdebugCli = - (sdebugCli debugSer) {scolorIsBold = Just False}} - parseArgs ("--maxFps" : n : rest) = - let debugSer = parseArgs rest - in debugSer {sdebugCli = - (sdebugCli debugSer) {smaxFps = Just $ max 1 $ read n}} - parseArgs ("--disableAutoYes" : rest) = - let debugSer = parseArgs rest - in debugSer {sdebugCli = (sdebugCli debugSer) {sdisableAutoYes = True}} - parseArgs ("--noAnim" : rest) = - let debugSer = parseArgs rest - in debugSer {sdebugCli = (sdebugCli debugSer) {snoAnim = Just True}} - parseArgs ("--savePrefix" : rest) = - let (params, args) = breakPar rest - debugSer = parseArgs args - in debugSer { ssavePrefixSer = params - , sdebugCli = - (sdebugCli debugSer) {ssavePrefixCli = params}} - parseArgs ("--frontendTeletype" : rest) = - let debugSer = parseArgs rest - in debugSer {sdebugCli = (sdebugCli debugSer) - {sfrontendTeletype = True}} - parseArgs ("--frontendNull" : rest) = - let debugSer = parseArgs rest - in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendNull = True}} - parseArgs ("--frontendLazy" : rest) = - let debugSer = parseArgs rest - in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendLazy = True}} - parseArgs ("--dbgMsgCli" : rest) = - let debugSer = parseArgs rest - in debugSer {sdebugCli = (sdebugCli debugSer) {sdbgMsgCli = True}} - parseArgs (wrong : _rest) = - error $ "Unrecognized: " ++ wrong ++ "\n" ++ unlines usage - in parseArgs +-- | Parser for server options from commandline arguments. +serverOptionsPI :: ParserInfo ServerOptions +serverOptionsPI = info ( helper <*> serverOptionsP ) + $ fullDesc + <> progDesc "Configure debug options here, gameplay options in configuration file." + +serverOptionsP :: Parser ServerOptions +serverOptionsP = do + ~(snewGameSer, scurChalSer) + <- serToChallenge <$> newGameP + knowMap <- knowMapP + knowEvents <- knowEventsP + knowItems <- knowItemsP + sniff <- sniffP + sallClear <- allClearP + sboostRandomItem <- boostRandItemP + sgameMode <- gameModeP + sautomateAll <- automateAllP + skeepAutomated <- keepAutomatedP + sstopAfterSeconds <- stopAfterSecsP + sstopAfterFrames <- stopAfterFramesP + sbenchmark <- benchmarkP + sdungeonRng <- setDungeonRngP + smainRng <- setMainRngP + sdumpInitRngs <- dumpInitRngsP + sdbgMsgSer <- dbgMsgSerP + sgtkFontFamily <- gtkFontFamilyP + sdlFontFile <- sdlFontFileP + sdlTtfSizeAdd <- sdlTtfSizeAddP + sdlFonSizeAdd <- sdlFonSizeAddP + sfontSize <- fontSizeP + sfontDir <- fontDirP + scolorIsBold <- noColorIsBoldP + smaxFps <- maxFpsP + sdisableAutoYes <- disableAutoYesP + snoAnim <- noAnimP + ssavePrefixSer <- savePrefixP + sfrontendTeletype <- frontendTeletypeP + sfrontendNull <- frontendNullP + sfrontendLazy <- frontendLazyP + sdbgMsgCli <- dbgMsgCliP + + pure ServerOptions + { + sclientOptions = ClientOptions + { stitle = Nothing + , snewGameCli = snewGameSer + , ssavePrefixCli = ssavePrefixSer + , .. + } + , sknowMap = knowMap || knowEvents || knowItems + , sknowEvents = knowEvents || knowItems + , sknowItems = knowItems + , .. + } + where + serToChallenge :: Maybe Int -> (Bool, Challenge) + serToChallenge Nothing = (False, defaultChallenge) + serToChallenge (Just cdiff) = (True, defaultChallenge {cdiff}) + +knowMapP :: Parser Bool +knowMapP = + switch ( long "knowMap" + <> help "Reveal map for all clients in the next game" ) + +knowEventsP :: Parser Bool +knowEventsP = + switch ( long "knowEvents" + <> help "Show all events in the next game (implies --knowMap)" ) + +knowItemsP :: Parser Bool +knowItemsP = + switch ( long "knowItems" + <> help "Auto-identify all items in the next game (implies --knowEvents)" ) + +sniffP :: Parser Bool +sniffP = + switch ( long "sniff" + <> help "Monitor all trafic between server and clients" ) + +allClearP :: Parser Bool +allClearP = + switch ( long "allClear" + <> help "Let all map tiles be translucent" ) + +boostRandItemP :: Parser Bool +boostRandItemP = + switch ( long "boostRandomItem" + <> help "Pick a random item and make it very common" ) + +gameModeP :: Parser (Maybe (GroupName ModeKind)) +gameModeP = optional $ toGameMode <$> + strOption ( long "gameMode" + <> metavar "MODE" + <> help "Start next game in the scenario indicated by MODE" ) + where + toGameMode :: String -> GroupName ModeKind + toGameMode = toGroupName . T.pack + +automateAllP :: Parser Bool +automateAllP = + switch ( long "automateAll" + <> help "Give control of all UI teams to computer" ) + +keepAutomatedP :: Parser Bool +keepAutomatedP = + switch ( long "keepAutomated" + <> help "Keep factions automated after game over" ) + +newGameP :: Parser (Maybe Int) +newGameP = optional $ + option auto ( long "newGame" + <> help "Start a new game, overwriting the save file, with difficulty for all UI players set to N" + <> metavar "N" ) + +stopAfterSecsP :: Parser (Maybe Int) +stopAfterSecsP = optional $ + option auto ( long "stopAfterSeconds" + <> help "Exit game session after around N seconds" + <> metavar "N" ) + +stopAfterFramesP :: Parser (Maybe Int) +stopAfterFramesP = optional $ + option auto ( long "stopAfterFrames" + <> help "Exit game session after around N frames" + <> metavar "N" ) + +benchmarkP :: Parser Bool +benchmarkP = + switch ( long "benchmark" + <> help "Restrict file IO, print timing stats" ) + +setDungeonRngP :: Parser (Maybe R.StdGen) +setDungeonRngP = optional $ + option auto ( long "setDungeonRng" + <> metavar "RNG_SEED" + <> help "Set dungeon generation RNG seed to string RNG_SEED" ) + +setMainRngP :: Parser (Maybe R.StdGen) +setMainRngP = optional $ + option auto ( long "setMainRng" + <> metavar "RNG_SEED" + <> help "Set the main game RNG seed to string RNG_SEED" ) + +dumpInitRngsP :: Parser Bool +dumpInitRngsP = + switch ( long "dumpInitRngs" + <> help "Dump the RNG seeds used to initialize the game" ) + +dbgMsgSerP :: Parser Bool +dbgMsgSerP = + switch ( long "dbgMsgSer" + <> help "Emit extra internal server debug messages" ) + +gtkFontFamilyP :: Parser (Maybe Text) +gtkFontFamilyP = optional $ T.pack <$> + strOption ( long "gtkFontFamily" + <> metavar "FONT_FAMILY" + <> help "Use FONT_FAMILY for the main game window in GTK frontend" ) + +sdlFontFileP :: Parser (Maybe Text) +sdlFontFileP = optional $ T.pack <$> + strOption ( long "sdlFontFile" + <> metavar "FONT_FILE" + <> help "Use FONT_FILE for the main game window in SDL2 frontend" ) + +sdlTtfSizeAddP :: Parser (Maybe Int) +sdlTtfSizeAddP = optional $ + option auto ( long "sdlTtfSizeAdd" + <> metavar "N" + <> help "Enlarge map cells by N over scalable font max height in SDL2 frontend" ) + +sdlFonSizeAddP :: Parser (Maybe Int) +sdlFonSizeAddP = optional $ + option auto ( long "sdlFonSizeAdd" + <> metavar "N" + <> help "Enlarge map cells by N on top of .fon font max height in SDL2 frontend" ) + +fontSizeP :: Parser (Maybe Int) +fontSizeP = optional $ + option auto ( long "fontSize" + <> metavar "N" + <> help "Use font size N for the main game window (interpreted differently by different graphical frontends)" ) + +fontDirP :: Parser (Maybe FilePath) +fontDirP = optional $ + option auto ( long "fontDir" + <> metavar "FILEPATH" + <> help "Take font files for the SDL2 frontend from FILEPATH" ) + +noColorIsBoldP :: Parser (Maybe Bool) +noColorIsBoldP = + flag Nothing (Just False) + ( long "noColorIsBold" + <> help "Refrain from making some bright color characters bolder" ) + +maxFpsP :: Parser (Maybe Int) +maxFpsP = optional $ max 1 <$> + option auto ( long "maxFps" + <> metavar "N" + <> help "Display at most N frames per second" ) + +disableAutoYesP :: Parser Bool +disableAutoYesP = + switch ( long "disableAutoYes" + <> help "Never auto-answer prompts, not even when UI faction is automated" ) + +noAnimP :: Parser (Maybe Bool) +noAnimP = + flag Nothing (Just True) + ( long "noAnim" + <> help "Don't show any animations" ) + +savePrefixP :: Parser String +savePrefixP = + strOption ( long "savePrefix" + <> metavar "PREFIX" + <> value "" + <> help "Prepend PREFIX to all savefile names" ) + +frontendTeletypeP :: Parser Bool +frontendTeletypeP = + switch ( long "frontendTeletype" + <> help "Use the line terminal frontend (for tests)" ) + +frontendNullP :: Parser Bool +frontendNullP = + switch ( long "frontendNull" + <> help "Use frontend with no display (for benchmarks)" ) + +frontendLazyP :: Parser Bool +frontendLazyP = + switch ( long "frontendLazy" + <> help "Use frontend that not even computes frames (for benchmarks)" ) + +dbgMsgCliP :: Parser Bool +dbgMsgCliP = + switch ( long "dbgMsgCli" + <> help "Emit extra internal client debug messages" ) diff --git a/Game/LambdaHack/Server/CommonM.hs b/Game/LambdaHack/Server/CommonM.hs --- a/Game/LambdaHack/Server/CommonM.hs +++ b/Game/LambdaHack/Server/CommonM.hs @@ -1,12 +1,16 @@ {-# LANGUAGE TupleSections #-} -- | Server operations common to many modules. module Game.LambdaHack.Server.CommonM - ( execFailure, getPerFid - , revealItems, moveStores, deduceQuits, deduceKilled - , electLeader, supplantLeader - , addActor, registerActor, addActorIid, projectFail, discoverIfNoEffects + ( execFailure, revealItems, moveStores, generalMoveItem + , deduceQuits, deduceKilled, electLeader, supplantLeader + , updatePer, recomputeCachePer, projectFail + , addActor, registerActor, addActorIid, discoverIfNoEffects , pickWeaponServer, currentSkillsServer - , recomputeCachePer +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , containerMoveItem, quitF, keepArenaFact, anyActorsAlive, projectBla + , addProjectile, getCacheLucid, getCacheTotal +#endif ) where import Prelude () @@ -17,35 +21,37 @@ import qualified Data.Text as T import qualified Text.Show.Pretty as Show.Pretty -import Game.LambdaHack.Atomic +import Game.LambdaHack.Atomic +import Game.LambdaHack.Client import qualified Game.LambdaHack.Common.Ability as Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemStrongest +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Server.Fov -import Game.LambdaHack.Server.ItemM -import Game.LambdaHack.Server.ItemRev -import Game.LambdaHack.Server.MonadServer -import Game.LambdaHack.Server.State +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.RuleKind +import Game.LambdaHack.Server.Fov +import Game.LambdaHack.Server.ItemM +import Game.LambdaHack.Server.ItemRev +import Game.LambdaHack.Server.MonadServer +import Game.LambdaHack.Server.ServerOptions +import Game.LambdaHack.Server.State -execFailure :: (MonadAtomic m, MonadServer m) +execFailure :: MonadServerAtomic m => ActorId -> RequestTimed a -> ReqFailure -> m () execFailure aid req failureSer = do -- Clients should rarely do that (only in case of invisible actors) @@ -65,25 +71,18 @@ <> debugShow body <> "\n" <> debugShow req <> "\n" <> debugShow failureSer execSfxAtomic $ SfxMsgFid fid $ SfxUnexpected failureSer -getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception -getPerFid fid lid = do - pers <- getsServer sperFid - let failFact = error $ "no perception for faction" `showFailure` (lid, fid) - fper = EM.findWithDefault failFact fid pers - failLvl = error $ "no perception for level" `showFailure` (lid, fid) - per = EM.findWithDefault failLvl lid fper - return $! per - -revealItems :: (MonadAtomic m, MonadServer m) => Maybe FactionId -> m () +revealItems :: MonadServerAtomic m => Maybe FactionId -> m () revealItems mfid = do - itemToF <- itemToFullServer + itemToF <- getsState itemToFull let discover aid store iid k = let itemFull = itemToF iid k c = CActor aid store in case itemDisco itemFull of - Just ItemDisco{itemKindId} -> do - seed <- getsServer $ (EM.! iid) . sitemSeedD - execUpdAtomic $ UpdDiscover c iid itemKindId seed + Just ItemDisco{itemKindId, itemKind} -> do + let isGem = maybe False (> 0) (lookup "gem" $ IK.ifreq itemKind) + unless isGem $ do -- a hack + seed <- getsServer $ (EM.! iid) . sitemSeedD + execUpdAtomic $ UpdDiscover c iid itemKindId seed _ -> error $ "" `showFailure` (mfid, c, iid, itemFull) f aid = do b <- getsState $ getActorBody aid @@ -97,7 +96,7 @@ as <- getsState $ EM.keys . sactorD mapM_ f as -moveStores :: (MonadAtomic m, MonadServer m) +moveStores :: MonadServerAtomic m => Bool -> ActorId -> CStore -> CStore -> m () moveStores verbose aid fromStore toStore = do b <- getsState $ getActorBody aid @@ -107,30 +106,59 @@ mapM_ execUpdAtomic move mapActorCStore_ fromStore g b -quitF :: (MonadAtomic m, MonadServer m) => Status -> FactionId -> m () +-- | Generate the atomic updates that jointly perform a given item move. +generalMoveItem :: MonadStateRead m + => Bool -> ItemId -> Int -> Container -> Container + -> m [UpdAtomic] +generalMoveItem verbose iid k c1 c2 = + case (c1, c2) of + (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2 + && cstore1 /= CSha + && cstore2 /= CSha -> + return [UpdMoveItem iid k aid1 cstore1 cstore2] + _ -> containerMoveItem verbose iid k c1 c2 + +containerMoveItem :: MonadStateRead m + => Bool -> ItemId -> Int -> Container -> Container + -> m [UpdAtomic] +containerMoveItem verbose iid k c1 c2 = do + bag <- getsState $ getContainerBag c1 + case iid `EM.lookup` bag of + Nothing -> error $ "" `showFailure` (iid, k, c1, c2) + Just (_, it) -> do + item <- getsState $ getItemBody iid + return [ UpdLoseItem verbose iid item (k, take k it) c1 + , UpdSpotItem verbose iid item (k, take k it) c2 ] + +quitF :: MonadServerAtomic m => Status -> FactionId -> m () quitF status fid = do fact <- getsState $ (EM.! fid) . sfactionD let oldSt = gquit fact + -- Note that it's the _old_ status that we check here. case stOutcome <$> oldSt of Just Killed -> return () -- Do not overwrite in case Just Defeated -> return () -- many things happen in 1 turn. Just Conquer -> return () Just Escape -> return () _ -> do + -- This runs regardless of the _new_ status. when (fhasUI $ gplayer fact) $ do - keepAutomated <- getsServer $ skeepAutomated . sdebugSer + keepAutomated <- getsServer $ skeepAutomated . soptions + -- Try to remove AI control of the UI faction, to show endgame info. when (isAIFact fact && fleaderMode (gplayer fact) /= LeaderNull && not keepAutomated) $ execUpdAtomic $ UpdAutoFaction fid False revealItems (Just fid) + -- Likely, by this time UI faction is no longer AI-controlled, + -- so the score will get registered. registerScore status fid execUpdAtomic $ UpdQuitFaction fid oldSt $ Just status modifyServer $ \ser -> ser {squit = True} -- check game over ASAP -- Send any UpdQuitFaction actions that can be deduced from factions' -- current state. -deduceQuits :: (MonadAtomic m, MonadServer m) => FactionId -> Status -> m () +deduceQuits :: MonadServerAtomic m => FactionId -> Status -> m () deduceQuits fid0 status@Status{stOutcome} | stOutcome `elem` [Defeated, Camping, Restart, Conquer] = error $ "no quitting to deduce" `showFailure` (fid0, status) @@ -192,7 +220,7 @@ -- We assume the actor in the second argument has HP <= 0 or is going to be -- dominated right now. Even if the actor is to be dominated, -- @bfid@ of the actor body is still the old faction. -deduceKilled :: (MonadAtomic m, MonadServer m) => ActorId -> m () +deduceKilled :: MonadServerAtomic m => ActorId -> m () deduceKilled aid = do Kind.COps{corule} <- getsState scops body <- getsState $ getActorBody aid @@ -208,28 +236,61 @@ as <- getsState $ fidActorNotProjAssocs fid return $! map fst as /= [aid] -electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m () +electLeader :: MonadServerAtomic m => FactionId -> LevelId -> ActorId -> m () electLeader fid lid aidDead = do - mleader <- getsState $ _gleader . (EM.! fid) . sfactionD + mleader <- getsState $ gleader . (EM.! fid) . sfactionD when (mleader == Just aidDead) $ do actorD <- getsState sactorD let ours (_, b) = bfid b == fid && not (bproj b) party = filter ours $ EM.assocs actorD + -- Prefer actors on level and with positive HP. + (positive, negative) = partition (\(_, b) -> bhp b > 0) party onLevel <- getsState $ fidActorRegularIds fid lid - let mleaderNew = case filter (/= aidDead) $ onLevel ++ map fst party of + let mleaderNew = case filter (/= aidDead) + $ onLevel ++ map fst (positive ++ negative) of [] -> Nothing aid : _ -> Just aid execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew -supplantLeader :: MonadAtomic m => FactionId -> ActorId -> m () +supplantLeader :: MonadServerAtomic m => FactionId -> ActorId -> m () supplantLeader fid aid = do fact <- getsState $ (EM.! fid) . sfactionD - unless (fleaderMode (gplayer fact) == LeaderNull) $ - execUpdAtomic $ UpdLeadFaction fid (_gleader fact) (Just aid) + unless (fleaderMode (gplayer fact) == LeaderNull) $ do + -- First update and send Perception so that the new leader + -- may report his environment. + b <- getsState $ getActorBody aid + valid <- getsServer $ (EM.! blid b) . (EM.! fid) . sperValidFid + unless valid $ updatePer fid (blid b) + execUpdAtomic $ UpdLeadFaction fid (gleader fact) (Just aid) +updatePer :: MonadServerAtomic m => FactionId -> LevelId -> m () +{-# INLINE updatePer #-} +updatePer fid lid = do + modifyServer $ \ser -> + ser {sperValidFid = EM.adjust (EM.insert lid True) fid $ sperValidFid ser} + sperFidOld <- getsServer sperFid + let perOld = sperFidOld EM.! fid EM.! lid + knowEvents <- getsServer $ sknowEvents . soptions + -- Performed in the State after action, e.g., with a new actor. + perNew <- recomputeCachePer fid lid + let inPer = diffPer perNew perOld + outPer = diffPer perOld perNew + unless (nullPer outPer && nullPer inPer) $ + unless knowEvents $ -- inconsistencies would quickly manifest + execSendPer fid lid outPer inPer perNew + +recomputeCachePer :: MonadServer m => FactionId -> LevelId -> m Perception +recomputeCachePer fid lid = do + total <- getCacheTotal fid lid + fovLucid <- getCacheLucid lid + let perNew = perceptionFromPTotal fovLucid total + fper = EM.adjust (EM.insert lid perNew) fid + modifyServer $ \ser -> ser {sperFid = fper $ sperFid ser} + return perNew + -- The missile item is removed from the store only if the projection -- went into effect (no failure occured). -projectFail :: (MonadAtomic m, MonadServer m) +projectFail :: MonadServerAtomic m => ActorId -- ^ actor projecting the item (is on current lvl) -> Point -- ^ target position of the projectile -> Int -- ^ digital line parameter @@ -252,11 +313,10 @@ case EM.lookup iid bag of Nothing -> return $ Just ProjectOutOfReach Just kit -> do - itemToF <- itemToFullServer + itemToF <- getsState itemToFull actorSk <- currentSkillsServer source - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! source - skill = EM.findWithDefault 0 Ability.AbProject actorSk + ar <- getsState $ getActorAspect source + let skill = EM.findWithDefault 0 Ability.AbProject actorSk itemFull@ItemFull{itemBase} = itemToF iid kit forced = isBlast || bproj sb calmE = calmEnough sb ar @@ -287,7 +347,7 @@ projectBla source pos rest iid cstore isBlast return Nothing -projectBla :: (MonadAtomic m, MonadServer m) +projectBla :: MonadServerAtomic m => ActorId -- ^ actor projecting the item (is on current lvl) -> Point -- ^ starting point of the projectile -> [Point] -- ^ rest of the trajectory of the projectile @@ -310,15 +370,12 @@ let c = CActor source cstore execUpdAtomic $ UpdLoseItem False iid item (1, take 1 it) c --- | Create a projectile actor containing the given missile. --- --- Projectile has no organs except for the trunk. -addProjectile :: (MonadAtomic m, MonadServer m) +addProjectile :: MonadServerAtomic m => Point -> [Point] -> ItemId -> ItemQuant -> LevelId -> FactionId -> Time -> Bool -> m () addProjectile bpos rest iid (_, it) blid bfid btime _isBlast = do - itemToF <- itemToFullServer + itemToF <- getsState itemToFull let itemFull@ItemFull{itemBase} = itemToF iid (1, take 1 it) (trajectory, (speed, _)) = itemTrajectory itemBase (bpos : rest) tweakBody b = b { bhp = oneM @@ -328,7 +385,7 @@ , borgan = EM.empty } -- don't confer bonuses from trunk void $ addActorIid iid itemFull True bfid bpos blid tweakBody btime -addActor :: (MonadAtomic m, MonadServer m) +addActor :: MonadServerAtomic m => GroupName ItemKind -> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Time -> m (Maybe ActorId) @@ -339,30 +396,23 @@ m5 <- rollItem 0 lid trunkFreq case m5 of Nothing -> return Nothing - Just (itemKnownRaw, itemFullRaw, itemDisco, seed, _) -> - registerActor itemKnownRaw itemFullRaw itemDisco seed - bfid pos lid tweakBody time + Just (itemKnownRaw, itemFullRaw, _, seed, _) -> + registerActor itemKnownRaw itemFullRaw seed bfid pos lid tweakBody time -registerActor :: (MonadAtomic m, MonadServer m) - => ItemKnown -> ItemFull -> ItemDisco -> ItemSeed +registerActor :: MonadServerAtomic m + => ItemKnown -> ItemFull -> ItemSeed -> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Time -> m (Maybe ActorId) -registerActor (kindIx, ar, damage, _) itemFullRaw itemDisco seed +registerActor (kindIx, ar, damage, _) itemFullRaw seed bfid pos lid tweakBody time = do let container = CTrunk bfid lid pos - -- Other code adds to @sdiscoBenefit@ only @iid@ and not any other items - -- that share the same @jkindIx@, so this is broken if such items - -- are not fully IDed from the start, so check that before risking a copy - -- of the same item, but with different @jfid@. - jfid = if IK.Identified `elem` IK.ifeature (itemKind itemDisco) - then Just bfid - else Nothing + jfid = Just bfid itemKnown = (kindIx, ar, damage, jfid) itemFull = itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}} trunkId <- registerItem itemFull itemKnown seed container False addActorIid trunkId itemFull False bfid pos lid tweakBody time -addActorIid :: (MonadAtomic m, MonadServer m) +addActorIid :: MonadServerAtomic m => ItemId -> ItemFull -> Bool -> FactionId -> Point -> LevelId -> (Actor -> Actor) -> Time -> m (Maybe ActorId) @@ -380,7 +430,7 @@ -- Create actor. factionD <- getsState sfactionD let fact = factionD EM.! bfid - curChalSer <- getsServer $ scurChalSer . sdebugSer + curChalSer <- getsServer $ scurChalSer . soptions nU <- nUI -- If difficulty is below standard, HP is added to the UI factions, -- otherwise HP is added to their enemies. @@ -422,21 +472,23 @@ Just (iid, (itemFull, _)) -> discoverIfNoEffects container iid itemFull return $ Just aid -discoverIfNoEffects :: (MonadAtomic m, MonadServer m) +discoverIfNoEffects :: MonadServerAtomic m => Container -> ItemId -> ItemFull -> m () discoverIfNoEffects c iid itemFull = case itemFull of - ItemFull{itemDisco=Just ItemDisco{itemKind=IK.ItemKind{IK.ieffects}}} - | any IK.forIdEffect ieffects -> return () -- discover by use - _ -> do + ItemFull{itemDisco=Just ItemDisco{itemKind}} + | any IK.forIdEffect (IK.ieffects itemKind) + || maybe False (> 0) (lookup "gem" $ IK.ifreq itemKind) -> -- a hack + return () -- discover by use, ignore gems + ItemFull{itemDisco=Just ItemDisco{itemKindId}} -> do seed <- getsServer $ (EM.! iid) . sitemSeedD - execUpdAtomic $ UpdDiscoverSeed c iid seed + execUpdAtomic $ UpdDiscover c iid itemKindId seed + _ -> error "server doesn't fully know item" pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore)) pickWeaponServer source = do - eqpAssocs <- fullAssocsServer source [CEqp] - bodyAssocs <- fullAssocsServer source [COrgan] + eqpAssocs <- getsState $ fullAssocs source [CEqp] + bodyAssocs <- getsState $ fullAssocs source [COrgan] actorSk <- currentSkillsServer source - actorAspect <- getsServer sactorAspect sb <- getsState $ getActorBody source let allAssocsRaw = eqpAssocs ++ bodyAssocs forced = bproj sb @@ -445,7 +497,7 @@ -- Server ignores item effects or it would leak item discovery info. -- In particular, it even uses weapons that would heal opponent, -- and not only in case of projectiles. - strongest <- pickWeaponM Nothing allAssocs actorSk actorAspect source + strongest <- pickWeaponM Nothing allAssocs actorSk source case strongest of [] -> return Nothing iis@((maxS, _) : _) -> do @@ -454,24 +506,21 @@ let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp return $ Just (iid, cstore) +-- @MonadStateRead@ would be enough, but the logic is sound only on server. currentSkillsServer :: MonadServer m => ActorId -> m Ability.Skills currentSkillsServer aid = do - ar <- getsServer $ (EM.! aid) . sactorAspect body <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid body) . sfactionD - let mleader = _gleader fact - getsState $ actorSkills mleader aid ar + let mleader = gleader fact + getsState $ actorSkills mleader aid getCacheLucid :: MonadServer m => LevelId -> m FovLucid getCacheLucid lid = do - discoAspect <- getsServer sdiscoAspect - actorAspect <- getsServer sactorAspect fovClearLid <- getsServer sfovClearLid fovLitLid <- getsServer sfovLitLid fovLucidLid <- getsServer sfovLucidLid let getNewLucid = getsState $ \s -> - lucidFromLevel discoAspect actorAspect fovClearLid fovLitLid - s lid (sdungeon s EM.! lid) + lucidFromLevel fovClearLid fovLitLid s lid (sdungeon s EM.! lid) case EM.lookup lid fovLucidLid of Just (FovValid fovLucid) -> return fovLucid _ -> do @@ -488,7 +537,7 @@ case ptotal perCacheOld of FovValid total -> return total FovInvalid -> do - actorAspect <- getsServer sactorAspect + actorAspect <- getsState sactorAspect fovClearLid <- getsServer sfovClearLid getActorB <- getsState $ flip getActorBody let perActorNew = @@ -502,12 +551,3 @@ fperCache = EM.adjust (EM.insert lid perCache) fid modifyServer $ \ser -> ser {sperCacheFid = fperCache $ sperCacheFid ser} return total - -recomputeCachePer :: MonadServer m => FactionId -> LevelId -> m Perception -recomputeCachePer fid lid = do - total <- getCacheTotal fid lid - fovLucid <- getCacheLucid lid - let perNew = perceptionFromPTotal fovLucid total - fper = EM.adjust (EM.insert lid perNew) fid - modifyServer $ \ser -> ser {sperFid = fper $ sperFid ser} - return perNew diff --git a/Game/LambdaHack/Server/DebugM.hs b/Game/LambdaHack/Server/DebugM.hs --- a/Game/LambdaHack/Server/DebugM.hs +++ b/Game/LambdaHack/Server/DebugM.hs @@ -1,7 +1,11 @@ --- | Debug output for requests and responseQs. +-- | Debug output for requests and responses. module Game.LambdaHack.Server.DebugM ( debugResponse , debugRequestAI, debugRequestUI +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , debugShow, debugPretty, debugPlain, DebugAid(..), debugAid +#endif ) where import Prelude () @@ -9,18 +13,17 @@ import Game.LambdaHack.Common.Prelude import qualified Data.EnumMap.Strict as EM -import Data.Int (Int64) +import Data.Int (Int64) import qualified Data.Text as T import qualified Text.Show.Pretty as Show.Pretty import Game.LambdaHack.Atomic +import Game.LambdaHack.Client import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.Response import Game.LambdaHack.Common.Time import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.State @@ -34,43 +37,51 @@ debugShow = T.pack . Show.Pretty.ppShow debugResponse :: MonadServer m => FactionId -> Response -> m () -debugResponse fid cmd = case cmd of - RespUpdAtomic cmdA@UpdPerception{} -> debugPlain fid cmd cmdA - RespUpdAtomic cmdA@UpdResume{} -> debugPlain fid cmd cmdA - RespUpdAtomic cmdA@UpdSpotTile{} -> debugPlain fid cmd cmdA - RespUpdAtomic cmdA -> debugPretty fid cmd cmdA +debugResponse fid resp = case resp of + RespUpdAtomic _ cmd@UpdPerception{} -> debugPlain fid "RespUpdAtomic" cmd + RespUpdAtomic _ cmd@UpdResume{} -> debugPlain fid "RespUpdAtomic" cmd + RespUpdAtomic _ cmd@UpdSpotTile{} -> debugPlain fid "RespUpdAtomic" cmd + RespUpdAtomic _ cmd -> debugPretty fid "RespUpdAtomic" cmd + RespUpdAtomicNoState cmd@UpdPerception{} -> + debugPlain fid "RespUpdAtomicNoState" cmd + RespUpdAtomicNoState cmd@UpdResume{} -> + debugPlain fid "RespUpdAtomicNoState" cmd + RespUpdAtomicNoState cmd@UpdSpotTile{} -> + debugPlain fid "RespUpdAtomicNoState" cmd + RespUpdAtomicNoState cmd -> + debugPretty fid "RespUpdAtomicNoState" cmd RespQueryAI aid -> do - d <- debugAid aid "RespQueryAI" cmd + d <- debugAid aid "RespQueryAI" serverPrint d RespSfxAtomic sfx -> do ps <- posSfxAtomic sfx - serverPrint $ debugShow (fid, cmd, ps) + serverPrint $ debugShow (fid, "RespSfxAtomic" :: Text, ps) RespQueryUI -> serverPrint "RespQueryUI" -debugPretty :: (MonadServer m, Show a) => FactionId -> a -> UpdAtomic -> m () -debugPretty fid cmd cmdA = do - ps <- posUpdAtomic cmdA - serverPrint $ debugShow (fid, cmd, ps) +debugPretty :: MonadServer m => FactionId -> Text -> UpdAtomic -> m () +debugPretty fid t cmd = do + ps <- posUpdAtomic cmd + serverPrint $ debugShow (fid, t, ps, cmd) -debugPlain :: (MonadServer m, Show a) => FactionId -> a -> UpdAtomic -> m () -debugPlain fid cmd cmdA = do - ps <- posUpdAtomic cmdA - serverPrint $ T.pack $ show (fid, cmd, ps) -- too large for pretty printing +debugPlain :: MonadServer m => FactionId -> Text -> UpdAtomic -> m () +debugPlain fid t cmd = do + ps <- posUpdAtomic cmd + serverPrint $ T.pack $ show (fid, t, ps, cmd) + -- too large for pretty printing -debugRequestAI :: MonadServer m => ActorId -> RequestAI -> m () -debugRequestAI aid cmd = do - d <- debugAid aid "AI request" cmd +debugRequestAI :: MonadServer m => ActorId -> m () +debugRequestAI aid = do + d <- debugAid aid "AI request" serverPrint d -debugRequestUI :: MonadServer m => ActorId -> RequestUI -> m () -debugRequestUI aid cmd = do - d <- debugAid aid "UI request" cmd +debugRequestUI :: MonadServer m => ActorId -> m () +debugRequestUI aid = do + d <- debugAid aid "UI request" serverPrint d -data DebugAid a = DebugAid +data DebugAid = DebugAid { label :: Text , aid :: ActorId - , cmd :: a , faction :: FactionId , lid :: LevelId , bHP :: Int64 @@ -79,14 +90,13 @@ } deriving Show -debugAid :: (MonadServer m, Show a) => ActorId -> Text -> a -> m Text -debugAid aid label cmd = do +debugAid :: MonadServer m => ActorId -> Text -> m Text +debugAid aid label = do b <- getsState $ getActorBody aid time <- getsState $ getLocalTime (blid b) btime <- getsServer $ (EM.! aid) . (EM.! blid b) . (EM.! bfid b) . sactorTime return $! debugShow DebugAid { label , aid - , cmd , faction = bfid b , lid = blid b , bHP = bhp b diff --git a/Game/LambdaHack/Server/DungeonGen.hs b/Game/LambdaHack/Server/DungeonGen.hs --- a/Game/LambdaHack/Server/DungeonGen.hs +++ b/Game/LambdaHack/Server/DungeonGen.hs @@ -1,9 +1,11 @@ --- | The unpopulated dungeon generation routine. +-- | The dungeon generation routine. It creates empty dungeons, without +-- actors and without items, either lying on the floor or embedded inside tiles. module Game.LambdaHack.Server.DungeonGen ( FreshDungeon(..), dungeonGen #ifdef EXPOSE_INTERNAL -- * Internal operations - , convertTileMaps, placeDownStairs, buildLevel, levelFromCaveKind + , convertTileMaps, buildTileMap, buildLevel, placeDownStairs + , levelFromCaveKind #endif ) where @@ -14,29 +16,28 @@ import qualified Control.Monad.Trans.State.Strict as St import qualified Data.EnumMap.Strict as EM import qualified Data.IntMap.Strict as IM -import Data.Tuple +import Data.Tuple import qualified System.Random as R -import Game.LambdaHack.Common.Frequency +import Game.LambdaHack.Common.Frequency import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Content.CaveKind -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.PlaceKind (PlaceKind) -import Game.LambdaHack.Content.TileKind (TileKind) +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.CaveKind +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.PlaceKind (PlaceKind) +import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK -import Game.LambdaHack.Server.DungeonGen.Cave -import Game.LambdaHack.Server.DungeonGen.Place +import Game.LambdaHack.Server.DungeonGen.Cave +import Game.LambdaHack.Server.DungeonGen.Place -convertTileMaps :: Kind.COps -> Bool - -> Rnd (Kind.Id TileKind) -> Maybe (Rnd (Kind.Id TileKind)) - -> Int -> Int -> TileMapEM +convertTileMaps :: Kind.COps -> Bool -> Rnd (Kind.Id TileKind) + -> Maybe (Rnd (Kind.Id TileKind)) -> Int -> Int -> TileMapEM -> Rnd TileMap convertTileMaps Kind.COps{coTileSpeedup} areAllWalkable cdefTile mpickPassable cxsize cysize ltile = do @@ -107,7 +108,7 @@ convertTileMaps cops areAllWalkable pickDefTile mpickPassable cxsize cysize dmap --- | Create a level from a cave. +-- Create a level from a cave. buildLevel :: Kind.COps -> Int -> GroupName CaveKind -> Int -> AbsDepth -> [Point] -> Rnd (Level, [Point]) @@ -169,7 +170,7 @@ (dnight cave) return (lvl, lstairsDouble ++ lstairsSingleDown) --- | Places yet another staircase (or escape), taking into account only +-- Places yet another staircase (or escape), taking into account only -- the already existing stairs. placeDownStairs :: CaveKind -> [Point] -> Rnd Point placeDownStairs kc@CaveKind{..} ps = do @@ -195,10 +196,9 @@ in if dist 0 np && distProj np then Just np else Nothing findPoint cxsize cysize f --- | Build rudimentary level from a cave kind. -levelFromCaveKind :: Kind.COps - -> CaveKind -> AbsDepth -> TileMap -> ([Point], [Point]) - -> Int -> [Point] -> Bool +-- Build rudimentary level from a cave kind. +levelFromCaveKind :: Kind.COps -> CaveKind -> AbsDepth -> TileMap + -> ([Point], [Point]) -> Int -> [Point] -> Bool -> Level levelFromCaveKind Kind.COps{coTileSpeedup} CaveKind{ cactorCoeff=lactorCoeff @@ -219,7 +219,6 @@ , lxsize = cxsize , lysize = cysize , lsmell = EM.empty - , ldesc = cname , lstair , lseen = 0 , lexplorable @@ -230,6 +229,8 @@ , litemFreq , lescape , lnight + , lname = cname + , ldesc = cdesc } -- | Freshly generated and not yet populated dungeon. diff --git a/Game/LambdaHack/Server/DungeonGen/Area.hs b/Game/LambdaHack/Server/DungeonGen/Area.hs --- a/Game/LambdaHack/Server/DungeonGen/Area.hs +++ b/Game/LambdaHack/Server/DungeonGen/Area.hs @@ -1,15 +1,14 @@ -- | Rectangular areas of levels and their basic operations. module Game.LambdaHack.Server.DungeonGen.Area - ( Area, toArea, fromArea, trivialArea, isTrivialArea - , grid, shrink, expand, sumAreas - , SpecialArea(..) + ( Area, toArea, fromArea, trivialArea, isTrivialArea, mkFixed + , SpecialArea(..), grid, shrink, expand, sumAreas ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.IntSet as IS @@ -35,6 +34,22 @@ isTrivialArea :: Area -> Bool isTrivialArea (Area x0 y0 x1 y1) = x0 == x1 && y0 == y1 + +-- Doesn't respect minimum sizes, because staircases are specified verbatim, +-- so can't be arbitrarily scaled up. +-- The size may be one more than what maximal size hint requests, +-- but this is safe (limited by area size) and makes up for the rigidity +-- of the fixed room sizes (e.g., that the size is always odd). +mkFixed :: (X, Y) -- ^ maximum size + -> Area -- ^ the containing area, not the room itself + -> Point -- ^ the center point + -> Area +mkFixed (xMax, yMax) area p@Point{..} = + let (x0, y0, x1, y1) = fromArea area + xradius = min ((xMax + 1) `div` 2) $ min (px - x0) (x1 - px) + yradius = min ((yMax + 1) `div` 2) $ min (py - y0) (y1 - py) + a = (px - xradius, py - yradius, px + xradius, py + yradius) + in fromMaybe (error $ "" `showFailure` (a, xMax, yMax, area, p)) $ toArea a data SpecialArea = SpecialArea Area diff --git a/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs b/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs --- a/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs +++ b/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs @@ -1,11 +1,15 @@ -- | Operations on the 'Area' type that involve random numbers. module Game.LambdaHack.Server.DungeonGen.AreaRnd ( -- * Picking points inside areas - xyInArea, mkVoidRoom, mkRoom, mkFixed + xyInArea, mkVoidRoom, mkRoom -- * Choosing connections , connectGrid, randomConnection -- * Plotting corridors , HV(..), Corridor, connectPlaces +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , connectGrid', sortPoint, mkCorridor, borderPlace +#endif ) where import Prelude () @@ -56,22 +60,6 @@ let a3 = (rx1, ry1, rx1 + xW - 1, ry1 + yW - 1) area3 = fromMaybe (error $ "" `showFailure` a3) $ toArea a3 return $! area3 - --- Doesn't respect minimum sizes, because staircases are specified verbatim, --- so can't be arbitrarily scaled up. --- The size may be one more than what maximal size hint requests, --- but this is safe (limited by area size) and makes up for the rigidity --- of the fixed room sizes (e.g., that the size is always odd). -mkFixed :: (X, Y) -- ^ maximum size - -> Area -- ^ the containing area, not the room itself - -> Point -- ^ the center point - -> Area -mkFixed (xM, yM) area p@Point{..} = - let (x0, y0, x1, y1) = fromArea area - xradius = min ((xM + 1) `div` 2) $ min (px - x0) (x1 - px) - yradius = min ((yM + 1) `div` 2) $ min (py - y0) (y1 - py) - a = (px - xradius, py - yradius, px + xradius, py + yradius) - in fromMaybe (error $ "" `showFailure` (a, xM, yM, area, p)) $ toArea a -- Choosing connections between areas in a grid diff --git a/Game/LambdaHack/Server/DungeonGen/Cave.hs b/Game/LambdaHack/Server/DungeonGen/Cave.hs --- a/Game/LambdaHack/Server/DungeonGen/Cave.hs +++ b/Game/LambdaHack/Server/DungeonGen/Cave.hs @@ -1,6 +1,10 @@ -- | Generation of caves (not yet inhabited dungeon levels) from cave kinds. module Game.LambdaHack.Server.DungeonGen.Cave ( Cave(..), bootFixedCenters, buildCave +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , pickOpening, digCorridors +#endif ) where import Prelude () @@ -9,21 +13,21 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Key (mapWithKeyM) +import Data.Key (mapWithKeyM) import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.CaveKind -import Game.LambdaHack.Content.PlaceKind -import Game.LambdaHack.Content.TileKind (TileKind) -import Game.LambdaHack.Server.DungeonGen.Area -import Game.LambdaHack.Server.DungeonGen.AreaRnd -import Game.LambdaHack.Server.DungeonGen.Place +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.CaveKind +import Game.LambdaHack.Content.PlaceKind +import Game.LambdaHack.Content.TileKind (TileKind) +import Game.LambdaHack.Server.DungeonGen.Area +import Game.LambdaHack.Server.DungeonGen.AreaRnd +import Game.LambdaHack.Server.DungeonGen.Place -- | The type of caves (not yet inhabited dungeon levels). data Cave = Cave @@ -38,29 +42,28 @@ bootFixedCenters :: CaveKind -> [Point] bootFixedCenters CaveKind{..} = [Point 4 3, Point (cxsize - 5) (cysize - 4)] -{- -Rogue cave is generated by an algorithm inspired by the original Rogue, -as follows: +{- | +Generate a cave using an algorithm inspired by the original Rogue, +as follows (in gross simplification): - * The available area is divided into a grid, e.g, 3 by 3, - where each of the 9 grid cells has approximately the same size. +* The available area is divided into a grid, e.g, 3 by 3, + where each of the 9 grid cells has approximately the same size. - * In each of the 9 grid cells one room is placed at a random position - and with a random size, but larger than The minimum size, - e.g, 2 by 2 floor tiles. +* In some of the 9 grid cells a room is placed at a random position + and with a random size, but larger than the minimum size, + e.g, 2 by 2 floor tiles. - * Rooms that are on horizontally or vertically adjacent grid cells - may be connected by a corridor. Corridors consist of 3 segments of straight - lines (either "horizontal, vertical, horizontal" or "vertical, horizontal, - vertical"). They end in openings in the walls of the room they connect. - It is possible that one or two of the 3 segments have length 0, such that - the resulting corridor is L-shaped or even a single straight line. +* Rooms that are on horizontally or vertically adjacent grid cells + may be connected by a corridor. Corridors consist of 3 segments of straight + lines (either "horizontal, vertical, horizontal" or "vertical, horizontal, + vertical"). They end in openings in the walls of the room they connect. + It is possible that one or two of the 3 segments have length 0, such that + the resulting corridor is L-shaped or even a single straight line. - * Corridors are generated randomly in such a way that at least every room - on the grid is connected, and a few more might be. It is not sufficient - to always connect all adjacent rooms. +* Corridors are generated randomly in such a way that at least every room + on the grid is connected, and a few more might be. It is not sufficient + to always connect all adjacent rooms, because not each cell holds a room. -} --- | Cave generation by an algorithm inspired by the original Rogue, buildCave :: Kind.COps -- ^ content definitions -> AbsDepth -- ^ depth of the level to generate -> AbsDepth -- ^ absolute depth diff --git a/Game/LambdaHack/Server/DungeonGen/Place.hs b/Game/LambdaHack/Server/DungeonGen/Place.hs --- a/Game/LambdaHack/Server/DungeonGen/Place.hs +++ b/Game/LambdaHack/Server/DungeonGen/Place.hs @@ -1,33 +1,37 @@ {-# LANGUAGE RankNTypes #-} -- | Generation of places from place kinds. module Game.LambdaHack.Server.DungeonGen.Place - ( TileMapEM, Place(..), isChancePos, placeCheck, buildFenceRnd, buildPlace + ( Place(..), TileMapEM, placeCheck, buildPlace, isChancePos, buildFenceRnd +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , interiorArea, olegend, ooverride, buildFence, tilePlace +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.Bits as Bits import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Text as T -import Game.LambdaHack.Common.Frequency +import Game.LambdaHack.Common.Frequency import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Point +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 (TileKind) +import Game.LambdaHack.Content.CaveKind +import Game.LambdaHack.Content.PlaceKind +import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK -import Game.LambdaHack.Server.DungeonGen.Area +import Game.LambdaHack.Server.DungeonGen.Area --- | The parameters of a place. All are immutable and set +-- | The parameters of a place. All are immutable and rolled and fixed -- at the time when a place is generated. data Place = Place { qkind :: Kind.Id PlaceKind diff --git a/Game/LambdaHack/Server/EndM.hs b/Game/LambdaHack/Server/EndM.hs --- a/Game/LambdaHack/Server/EndM.hs +++ b/Game/LambdaHack/Server/EndM.hs @@ -1,7 +1,10 @@ --- | The main loop of the server, processing human and computer player --- moves turn by turn. +-- | Server operations used when ending game and deciding whether to end. module Game.LambdaHack.Server.EndM - ( endOrLoop, dieSer + ( endOrLoop, dieSer, writeSaveAll +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , gameExit, dropAllItems +#endif ) where import Prelude () @@ -11,6 +14,7 @@ import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Atomic +import Game.LambdaHack.Client import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction @@ -20,16 +24,19 @@ import Game.LambdaHack.Common.State import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Server.CommonM +import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.HandleEffectM import Game.LambdaHack.Server.ItemM import Game.LambdaHack.Server.MonadServer +import Game.LambdaHack.Server.ProtocolM +import Game.LambdaHack.Server.ServerOptions import Game.LambdaHack.Server.State -- | Continue or exit or restart the game. -endOrLoop :: (MonadAtomic m, MonadServer m) - => m () -> (Maybe (GroupName ModeKind) -> m ()) -> m () -> m () +endOrLoop :: (MonadServerAtomic m, MonadServerReadRequest m) + => m () -> (Maybe (GroupName ModeKind) -> m ()) -> m () -> m () -endOrLoop loop restart gameExit gameSave = do +endOrLoop loop restart gameSave = do factionD <- getsState sfactionD let inGame fact = case gquit fact of Nothing -> True @@ -56,10 +63,55 @@ | not $ null campers -> gameExit -- and @loop@ is not called | otherwise -> loop -- continue current game -dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> m () +gameExit :: (MonadServerAtomic m, MonadServerReadRequest m) => m () +gameExit = do + -- Verify that the not saved caches are equal to future reconstructed. + -- Otherwise, save/restore would change game state. +-- debugPossiblyPrint "Verifying all perceptions." + sperCacheFid <- getsServer sperCacheFid + sperValidFid <- getsServer sperValidFid + sactorAspect2 <- getsState sactorAspect + sfovLucidLid <- getsServer sfovLucidLid + sfovClearLid <- getsServer sfovClearLid + sfovLitLid <- getsServer sfovLitLid + sperFid <- getsServer sperFid + actorAspect <- getsState actorAspectInDungeon + ( fovLitLid, fovClearLid, fovLucidLid + ,perValidFid, perCacheFid, perFid ) <- getsState perFidInDungeon + let !_A7 = assert (sfovLitLid == fovLitLid + `blame` "wrong accumulated sfovLitLid" + `swith` (sfovLitLid, fovLitLid)) () + !_A6 = assert (sfovClearLid == fovClearLid + `blame` "wrong accumulated sfovClearLid" + `swith` (sfovClearLid, fovClearLid)) () + !_A5 = assert (sactorAspect2 == actorAspect + `blame` "wrong accumulated sactorAspect" + `swith` (sactorAspect2, actorAspect)) () + !_A4 = assert (sfovLucidLid == fovLucidLid + `blame` "wrong accumulated sfovLucidLid" + `swith` (sfovLucidLid, fovLucidLid)) () + !_A3 = assert (sperValidFid == perValidFid + `blame` "wrong accumulated sperValidFid" + `swith` (sperValidFid, perValidFid)) () + !_A2 = assert (sperCacheFid == perCacheFid + `blame` "wrong accumulated sperCacheFid" + `swith` (sperCacheFid, perCacheFid)) () + !_A1 = assert (sperFid == perFid + `blame` "wrong accumulated perception" + `swith` (sperFid, perFid)) () + -- 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" +-- debugPossiblyPrint "Killing all clients." + killAllClients +-- debugPossiblyPrint "All clients killed." + return () + +dieSer :: MonadServerAtomic m => ActorId -> Actor -> m () dieSer aid b = do unless (bproj b) $ do - discoKind <- getsServer sdiscoKind + discoKind <- getsState sdiscoKind trunk <- getsState $ getItemBody $ btrunk b let KindMean{kmKind} = discoKind EM.! jkindIx trunk execUpdAtomic $ UpdRecordKill aid kmKind 1 @@ -71,7 +123,7 @@ -- Projectiles can't drop stash, because they are blind and so the faction -- would not see the actor that drops the stash, leading to a crash. -- But this is OK; projectiles can't be leaders, so stash dropped earlier. - when (isNothing $ _gleader fact) $ moveStores False aid CSha CInv + when (isNothing $ gleader fact) $ moveStores False aid CSha CInv -- If the actor was a projectile and no effect was triggered by hitting -- an enemy, the item still exists and @OnSmash@ effects will be triggered: dropAllItems aid b @@ -79,8 +131,16 @@ execUpdAtomic $ UpdDestroyActor aid b2 [] -- | Drop all actor's items. -dropAllItems :: (MonadAtomic m, MonadServer m) - => ActorId -> Actor -> m () +dropAllItems :: MonadServerAtomic m => ActorId -> Actor -> m () dropAllItems aid b = do mapActorCStore_ CInv (dropCStoreItem False CInv aid b maxBound) b mapActorCStore_ CEqp (dropCStoreItem False CEqp aid b maxBound) b + +-- | Save game on server and all clients. +writeSaveAll :: MonadServerAtomic m => Bool -> m () +writeSaveAll uiRequested = do + bench <- getsServer $ sbenchmark . sclientOptions . soptions + noConfirmsGame <- isNoConfirmsGame + when (uiRequested || not bench && not noConfirmsGame) $ do + execUpdAtomic UpdWriteSave + saveServer diff --git a/Game/LambdaHack/Server/Fov.hs b/Game/LambdaHack/Server/Fov.hs --- a/Game/LambdaHack/Server/Fov.hs +++ b/Game/LambdaHack/Server/Fov.hs @@ -1,32 +1,24 @@ --- | Field Of View scanning with a variety of algorithms. +-- | Field Of View scanning. +-- -- See -- for discussion. module Game.LambdaHack.Server.Fov ( -- * Perception cache - FovValid(..) - , PerValidFid - , PerReachable(..) - , CacheBeforeLucid(..) - , PerActor - , PerceptionCache(..) - , PerCacheLid - , PerCacheFid + FovValid(..), PerValidFid + , PerReachable(..), CacheBeforeLucid(..), PerActor + , PerceptionCache(..), PerCacheLid, PerCacheFid -- * Data used in FOV computation and cached to speed it up , FovShine(..), FovLucid(..), FovLucidLid , FovClear(..), FovClearLid, FovLit (..), FovLitLid - -- * Update of invalidated Fov data - , perceptionFromPTotal, perActorFromLevel, totalFromPerActor, lucidFromLevel - -- * Computation of initial perception and caches - , perFidInDungeon, aspectRecordFromActorServer, boundSightByCalm + -- * Operations + , perceptionFromPTotal, perActorFromLevel, boundSightByCalm + , totalFromPerActor, lucidFromLevel, perFidInDungeon #ifdef EXPOSE_INTERNAL -- * Internal operations - , cacheBeforeLucidFromActor - , perceptionCacheFromLevel, perLidFromFaction - , clearFromLevel, clearInDungeon - , litFromLevel, litInDungeon, shineFromLevel - , floorLightSources, lucidFromItems, lucidInDungeon - -- * The actual Fov algorithm - , fullscan + , cacheBeforeLucidFromActor, shineFromLevel, floorLightSources, lucidFromItems + , litFromLevel, litInDungeon, clearFromLevel, clearInDungeon, lucidInDungeon + , perLidFromFaction, perceptionCacheFromLevel + , Matrix, fullscan #endif ) where @@ -36,23 +28,23 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Int (Int64) -import GHC.Exts (inline) +import Data.Int (Int64) +import GHC.Exts (inline) -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Server.FovDigital +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Server.FovDigital -- * Perception cache types @@ -100,10 +92,7 @@ -- | Map from level positions that currently hold item or actor(s) with shine -- to the maximum of radiuses of the shining lights. -- --- Note: @ActorAspect@ and @FovShine@ shoudn't be in @State@, --- because on client they need to be updated every time an item discovery --- is made, unlike on the server, where it's much simpler and cheaper. --- BTW, floor and (many projectile) actors light on a single tile +-- Note that floor and (many projectile) actors light on a single tile -- should be additive for @FovShine@ to be incrementally updated. -- -- @FovShine@ should not even be kept in @StateServer@, because it's cheap @@ -175,7 +164,7 @@ totalFromPerActor :: PerActor -> CacheBeforeLucid totalFromPerActor perActor = - let as = map (\a -> case a of + let as = map (\case FovValid x -> x FovInvalid -> error $ "" `showFailure` perActor) $ EM.elems perActor @@ -196,25 +185,23 @@ -- but it's rare that cmd changed them, but not the perception -- (e.g., earthquake in an uninhabited corner of the active arena, -- but the we'd probably want some feedback, at least sound). -lucidFromLevel :: DiscoveryAspect -> ActorAspect -> FovClearLid -> FovLitLid - -> State -> LevelId -> Level +lucidFromLevel :: FovClearLid -> FovLitLid -> State -> LevelId -> Level -> FovLucid -lucidFromLevel discoAspect actorAspect fovClearLid fovLitLid s lid lvl = - let shine = shineFromLevel discoAspect actorAspect s lid lvl +lucidFromLevel fovClearLid fovLitLid s lid lvl = + let shine = shineFromLevel s lid lvl lucids = lucidFromItems (fovClearLid EM.! lid) $ EM.assocs $ fovShine shine litTiles = fovLitLid EM.! lid in FovLucid $ ES.unions $ fovLit litTiles : map fovLucid lucids -shineFromLevel :: DiscoveryAspect -> ActorAspect -> State -> LevelId -> Level - -> FovShine -shineFromLevel discoAspect actorAspect s lid lvl = +shineFromLevel :: State -> LevelId -> Level -> FovShine +shineFromLevel s lid lvl = let actorLights = [ (bpos b, radius) | (aid, b) <- inline actorAssocs (const True) lid s - , let radius = aShine $ actorAspect EM.! aid + , let radius = aShine $ sactorAspect s EM.! aid , radius > 0 ] - floorLights = floorLightSources discoAspect lvl + floorLights = floorLightSources (sdiscoAspect s) lvl allLights = floorLights ++ actorLights -- If there is light both on the floor and carried by actor -- (or several projectile actors), its radius is the maximum. @@ -249,32 +236,19 @@ -- * Computation of initial perception and caches -- | Calculate the perception and its caches for the whole dungeon. -perFidInDungeon :: DiscoveryAspect -> State - -> ( ActorAspect, FovLitLid, FovClearLid, FovLucidLid - , PerValidFid, PerCacheFid, PerFid) -perFidInDungeon discoAspect s = - let actorAspect = actorAspectInDungeon discoAspect s - fovLitLid = litInDungeon s +perFidInDungeon :: State -> ( FovLitLid, FovClearLid, FovLucidLid + , PerValidFid, PerCacheFid, PerFid) +perFidInDungeon s = + let fovLitLid = litInDungeon s fovClearLid = clearInDungeon s - fovLucidLid = - lucidInDungeon discoAspect actorAspect fovClearLid fovLitLid s + fovLucidLid = lucidInDungeon fovClearLid fovLitLid s perValidLid = EM.map (const True) (sdungeon s) perValidFid = EM.map (const perValidLid) (sfactionD s) - f fid _ = perLidFromFaction actorAspect fovLucidLid fovClearLid fid s + f fid _ = perLidFromFaction fovLucidLid fovClearLid fid s em = EM.mapWithKey f $ sfactionD s - in ( actorAspect, fovLitLid, fovClearLid, fovLucidLid + in ( fovLitLid, fovClearLid, fovLucidLid , perValidFid, EM.map snd em, EM.map fst em) -aspectRecordFromActorServer :: DiscoveryAspect -> Actor -> AspectRecord -aspectRecordFromActorServer discoAspect b = - let processIid (iid, (k, _)) = (discoAspect EM.! iid, k) - processBag ass = sumAspectRecord $ map processIid ass - in processBag $ EM.assocs (borgan b) ++ EM.assocs (beqp b) - -actorAspectInDungeon :: DiscoveryAspect -> State -> ActorAspect -actorAspectInDungeon discoAspect s = - EM.map (aspectRecordFromActorServer discoAspect) $ sactorD s - litFromLevel :: Kind.COps -> Level -> FovLit litFromLevel Kind.COps{coTileSpeedup} Level{ltile} = let litSet p t set = if Tile.isLit coTileSpeedup t then p : set else set @@ -290,23 +264,20 @@ clearInDungeon :: State -> FovClearLid clearInDungeon s = EM.map (clearFromLevel (scops s)) $ sdungeon s -lucidInDungeon :: DiscoveryAspect -> ActorAspect -> FovClearLid -> FovLitLid - -> State - -> FovLucidLid -lucidInDungeon discoAspect actorAspect fovClearLid fovLitLid s = +lucidInDungeon :: FovClearLid -> FovLitLid -> State-> FovLucidLid +lucidInDungeon fovClearLid fovLitLid s = EM.mapWithKey (\lid lvl -> FovValid $ - lucidFromLevel discoAspect actorAspect fovClearLid fovLitLid s lid lvl) + lucidFromLevel fovClearLid fovLitLid s lid lvl) $ sdungeon s -- | Calculate perception of a faction. -perLidFromFaction :: ActorAspect -> FovLucidLid -> FovClearLid - -> FactionId -> State +perLidFromFaction :: FovLucidLid -> FovClearLid -> FactionId -> State -> (PerLid, PerCacheLid) -perLidFromFaction actorAspect fovLucidLid fovClearLid fid s = +perLidFromFaction fovLucidLid fovClearLid fid s = let em = EM.mapWithKey (\lid _ -> - perceptionCacheFromLevel actorAspect fovClearLid fid lid s) - (sdungeon s) + perceptionCacheFromLevel fovClearLid fid lid s) + (sdungeon s) fovLucid lid = case EM.lookup lid fovLucidLid of Just (FovValid fl) -> fl _ -> error $ "" `showFailure` (lid, fovLucidLid) @@ -316,14 +287,13 @@ perceptionFromPTotal (fovLucid lid) (getValid (ptotal pc))) em , em ) -perceptionCacheFromLevel :: ActorAspect -> FovClearLid - -> FactionId -> LevelId -> State +perceptionCacheFromLevel :: FovClearLid -> FactionId -> LevelId -> State -> PerceptionCache -perceptionCacheFromLevel actorAspect fovClearLid fid lid s = +perceptionCacheFromLevel fovClearLid fid lid s = let fovClear = fovClearLid EM.! lid lvlBodies = inline actorAssocs (== fid) lid s f (aid, b) = - let ar@AspectRecord{..} = actorAspect EM.! aid + let ar@AspectRecord{..} = sactorAspect s EM.! aid in if aSight <= 0 && aNocto <= 0 && aSmell <= 0 -- dumb missiles then Nothing else Just (aid, FovValid $ cacheBeforeLucidFromActor fovClear b ar) diff --git a/Game/LambdaHack/Server/FovDigital.hs b/Game/LambdaHack/Server/FovDigital.hs --- a/Game/LambdaHack/Server/FovDigital.hs +++ b/Game/LambdaHack/Server/FovDigital.hs @@ -23,7 +23,7 @@ import qualified Data.EnumSet as ES -import Game.LambdaHack.Common.Point hiding (inside) +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -- | Distance from the (0, 0) point where FOV originates. diff --git a/Game/LambdaHack/Server/HandleAtomicM.hs b/Game/LambdaHack/Server/HandleAtomicM.hs --- a/Game/LambdaHack/Server/HandleAtomicM.hs +++ b/Game/LambdaHack/Server/HandleAtomicM.hs @@ -1,10 +1,10 @@ --- | Handle atomic commands before they are executed to change State --- and sent to clients. +-- | Handle atomic commands on the server, after they are executed +-- to change server 'State' and before they are sent to clients. module Game.LambdaHack.Server.HandleAtomicM ( cmdAtomicSemSer #ifdef EXPOSE_INTERNAL -- * Internal operations - , addItemToActor, updateSclear, updateSlit + , invalidateArenas, updateSclear, updateSlit , invalidateLucidLid, invalidateLucidAid , actorHasShine, itemAffectsShineRadius, itemAffectsPerRadius , addPerActor, addPerActorAny, deletePerActor, deletePerActorAny @@ -19,110 +19,126 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Game.LambdaHack.Atomic -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Atomic +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Content.TileKind (TileKind) -import Game.LambdaHack.Server.Fov -import Game.LambdaHack.Server.MonadServer -import Game.LambdaHack.Server.State +import Game.LambdaHack.Content.TileKind (TileKind) +import Game.LambdaHack.Server.Fov +import Game.LambdaHack.Server.MonadServer +import Game.LambdaHack.Server.State -- | Effect of atomic actions on server state is calculated --- with the global state from before the command is executed. -cmdAtomicSemSer :: MonadServer m => UpdAtomic -> m () -cmdAtomicSemSer cmd = case cmd of +-- with the global state from after the command is executed +-- (except where the supplied @oldState@ is used). +cmdAtomicSemSer :: MonadServer m => State -> UpdAtomic -> m () +cmdAtomicSemSer oldState cmd = case cmd of UpdCreateActor aid b _ -> do - discoAspect <- getsServer sdiscoAspect - let aspectRecord = aspectRecordFromActorServer discoAspect b - f = EM.insert aid aspectRecord - modifyServer $ \ser -> ser {sactorAspect = f $ sactorAspect ser} - actorAspect <- getsServer sactorAspect - -- We don't have the body in the State yet, hence no @invalidateLucidAid@. + actorAspect <- getsState sactorAspect when (actorHasShine actorAspect aid) $ invalidateLucidLid $ blid b addPerActor aid b UpdDestroyActor aid b _ -> do - deletePerActor aid b - actorAspectOld <- getsServer sactorAspect + let actorAspectOld = sactorAspect oldState when (actorHasShine actorAspectOld aid) $ invalidateLucidLid $ blid b - modifyServer $ \ser -> ser {sactorAspect = EM.delete aid $ sactorAspect ser} + deletePerActor actorAspectOld aid b modifyServer $ \ser -> ser {sactorTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b) (sactorTime ser)} UpdCreateItem iid _ _ (CFloor lid _) -> do - discoAspect <- getsServer sdiscoAspect + discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid []) $ invalidateLucidLid lid - UpdCreateItem iid _ (k, _) (CActor aid store) -> do - discoAspect <- getsServer sdiscoAspect + UpdCreateItem iid _ _ (CActor aid store) -> do + discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid [store]) $ invalidateLucidAid aid - when (store `elem` [CEqp, COrgan]) $ do - addItemToActor iid k aid + when (store `elem` [CEqp, COrgan]) $ when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid UpdDestroyItem iid _ _ (CFloor lid _) -> do - discoAspect <- getsServer sdiscoAspect + discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid []) $ invalidateLucidLid lid - UpdDestroyItem iid _ (k, _) (CActor aid store) -> do - discoAspect <- getsServer sdiscoAspect + UpdDestroyItem iid _ _ (CActor aid store) -> do + discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid [store]) $ invalidateLucidAid aid - when (store `elem` [CEqp, COrgan]) $ do - addItemToActor iid (-k) aid + when (store `elem` [CEqp, COrgan]) $ when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid UpdSpotActor aid b _ -> do -- On server, it does't affect aspects, but does affect lucid (Ascend). - actorAspect <- getsServer sactorAspect - -- We don't have the body in the State yet, hence no @invalidateLucidAid@. + actorAspect <- getsState sactorAspect when (actorHasShine actorAspect aid) $ invalidateLucidLid $ blid b addPerActor aid b UpdLoseActor aid b _ -> do -- On server, it does't affect aspects, but does affect lucid (Ascend). - deletePerActor aid b - actorAspectOld <- getsServer sactorAspect + let actorAspectOld = sactorAspect oldState when (actorHasShine actorAspectOld aid) $ invalidateLucidLid $ blid b + deletePerActor actorAspectOld aid b modifyServer $ \ser -> ser {sactorTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b) (sactorTime ser)} UpdSpotItem _ iid _ _ (CFloor lid _) -> do - discoAspect <- getsServer sdiscoAspect + discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid []) $ invalidateLucidLid lid - UpdSpotItem _ iid _ (k, _) (CActor aid store) -> do - discoAspect <- getsServer sdiscoAspect + UpdSpotItem _ iid _ _ (CActor aid store) -> do + discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid [store]) $ invalidateLucidAid aid - when (store `elem` [CEqp, COrgan]) $ do - addItemToActor iid k aid + when (store `elem` [CEqp, COrgan]) $ when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid UpdLoseItem _ iid _ _ (CFloor lid _) -> do - discoAspect <- getsServer sdiscoAspect + discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid []) $ invalidateLucidLid lid - UpdLoseItem _ iid _ (k, _) (CActor aid store) -> do - discoAspect <- getsServer sdiscoAspect + UpdLoseItem _ iid _ _ (CActor aid store) -> do + discoAspect <- getsState sdiscoAspect when (itemAffectsShineRadius discoAspect iid [store]) $ invalidateLucidAid aid - when (store `elem` [CEqp, COrgan]) $ do - addItemToActor iid (-k) aid + when (store `elem` [CEqp, COrgan]) $ when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid + UpdSpotItemBag (CFloor lid _) bag _ais -> do + discoAspect <- getsState sdiscoAspect + let iids = EM.keys bag + when (any (\iid -> itemAffectsShineRadius discoAspect iid []) iids) $ + invalidateLucidLid lid + UpdSpotItemBag (CActor aid store) bag _ais -> do + discoAspect <- getsState sdiscoAspect + let iids = EM.keys bag + when (any (\iid -> itemAffectsShineRadius discoAspect iid [store]) iids) $ + invalidateLucidAid aid + when (store `elem` [CEqp, COrgan]) $ + when (any (itemAffectsPerRadius discoAspect) iids) $ + reconsiderPerActor aid + UpdLoseItemBag (CFloor lid _) bag _ais -> do + discoAspect <- getsState sdiscoAspect + let iids = EM.keys bag + when (any (\iid -> itemAffectsShineRadius discoAspect iid []) iids) $ + invalidateLucidLid lid + UpdLoseItemBag (CActor aid store) bag _ais -> do + discoAspect <- getsState sdiscoAspect + let iids = EM.keys bag + when (any (\iid -> itemAffectsShineRadius discoAspect iid [store]) iids) $ + invalidateLucidAid aid + when (store `elem` [CEqp, COrgan]) $ + when (any (itemAffectsPerRadius discoAspect) iids) $ + reconsiderPerActor aid UpdMoveActor aid _ _ -> do - actorAspect <- getsServer sactorAspect + actorAspect <- getsState sactorAspect when (actorHasShine actorAspect aid) $ invalidateLucidAid aid invalidatePerActor aid UpdDisplaceActor aid1 aid2 -> do - actorAspect <- getsServer sactorAspect + actorAspect <- getsState sactorAspect when (actorHasShine actorAspect aid1 || actorHasShine actorAspect aid2) $ invalidateLucidAid aid1 -- the same lid as aid2 invalidatePerActor aid1 invalidatePerActor aid2 - UpdMoveItem iid k aid s1 s2 -> do - discoAspect <- getsServer sdiscoAspect + UpdMoveItem iid _k aid s1 s2 -> do + discoAspect <- getsState sdiscoAspect let itemAffectsPer = itemAffectsPerRadius discoAspect iid invalidatePer = when itemAffectsPer $ reconsiderPerActor aid itemAffectsShine = itemAffectsShineRadius discoAspect iid [s1, s2] @@ -131,26 +147,22 @@ CEqp -> case s2 of COrgan -> return () _ -> do - addItemToActor iid (-k) aid - invalidatePer invalidateLucid + invalidatePer COrgan -> case s2 of CEqp -> return () _ -> do - addItemToActor iid (-k) aid - invalidatePer invalidateLucid - _ -> do - when (s2 `elem` [CEqp, COrgan]) $ do - addItemToActor iid k aid invalidatePer + _ -> do invalidateLucid -- from itemAffects, s2 provides light or s1 is CGround - UpdRefillCalm aid n -> do - actorAspect <- getsServer sactorAspect + when (s2 `elem` [CEqp, COrgan]) invalidatePer + UpdRefillCalm aid _ -> do + AspectRecord{aSight} <- getsState $ getActorAspect aid body <- getsState $ getActorBody aid - let AspectRecord{aSight} = actorAspect EM.! aid - radiusOld = boundSightByCalm aSight (bcalm body) - radiusNew = boundSightByCalm aSight (bcalm body + n) + let oldBody = getActorBody aid oldState + radiusOld = boundSightByCalm aSight (bcalm oldBody) + radiusNew = boundSightByCalm aSight (bcalm body) when (radiusOld /= radiusNew) $ invalidatePerActor aid UpdLeadFaction{} -> invalidateArenas UpdRecordKill{} -> invalidateArenas @@ -164,16 +176,9 @@ invalidateArenas :: MonadServer m => m () invalidateArenas = modifyServer $ \ser -> ser {svalidArenas = False} -addItemToActor :: MonadServer m => ItemId -> Int -> ActorId -> m () -addItemToActor iid k aid = do - discoAspect <- getsServer sdiscoAspect - let arItem = discoAspect EM.! iid - g arActor = sumAspectRecord [(arActor, 1), (arItem, k)] - f = EM.adjust g aid - modifyServer $ \ser -> ser {sactorAspect = f $ sactorAspect ser} - updateSclear :: MonadServer m - => LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind -> m Bool + => LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind + -> m Bool updateSclear lid pos fromTile toTile = do Kind.COps{coTileSpeedup} <- getsState scops let fromClear = Tile.isClear coTileSpeedup fromTile @@ -203,7 +208,7 @@ ser { sfovLucidLid = EM.insert lid FovInvalid $ sfovLucidLid ser , sperValidFid = EM.map (EM.insert lid False) $ sperValidFid ser } -invalidateLucidAid :: MonadServer m => ActorId -> m () +invalidateLucidAid :: MonadServer m => ActorId -> m () invalidateLucidAid aid = do lid <- getsState $ blid . getActorBody aid invalidateLucidLid lid @@ -229,8 +234,7 @@ addPerActor :: MonadServer m => ActorId -> Actor -> m () addPerActor aid b = do - actorAspect <- getsServer sactorAspect - let AspectRecord{..} = actorAspect EM.! aid + AspectRecord{..} <- getsState $ getActorAspect aid unless (aSight <= 0 && aNocto <= 0 && aSmell <= 0) $ addPerActorAny aid b addPerActorAny :: MonadServer m => ActorId -> Actor -> m () @@ -245,10 +249,9 @@ , sperValidFid = EM.adjust (EM.insert lid False) fid $ sperValidFid ser } -deletePerActor :: MonadServer m => ActorId -> Actor -> m () -deletePerActor aid b = do - actorAspect <- getsServer sactorAspect - let AspectRecord{..} = actorAspect EM.! aid +deletePerActor :: MonadServer m => ActorAspect -> ActorId -> Actor -> m () +deletePerActor actorAspectOld aid b = do + let AspectRecord{..} = actorAspectOld EM.! aid unless (aSight <= 0 && aNocto <= 0 && aSmell <= 0) $ deletePerActorAny aid b deletePerActorAny :: MonadServer m => ActorId -> Actor -> m () @@ -265,8 +268,7 @@ invalidatePerActor :: MonadServer m => ActorId -> m () invalidatePerActor aid = do - actorAspect <- getsServer sactorAspect - let AspectRecord{..} = actorAspect EM.! aid + AspectRecord{..} <- getsState $ getActorAspect aid unless (aSight <= 0 && aNocto <= 0 && aSmell <= 0) $ do b <- getsState $ getActorBody aid addPerActorAny aid b @@ -274,8 +276,7 @@ reconsiderPerActor :: MonadServer m => ActorId -> m () reconsiderPerActor aid = do b <- getsState $ getActorBody aid - actorAspect <- getsServer sactorAspect - let AspectRecord{..} = actorAspect EM.! aid + AspectRecord{..} <- getsState $ getActorAspect aid if aSight <= 0 && aNocto <= 0 && aSmell <= 0 then do perCacheFid <- getsServer sperCacheFid diff --git a/Game/LambdaHack/Server/HandleEffectM.hs b/Game/LambdaHack/Server/HandleEffectM.hs --- a/Game/LambdaHack/Server/HandleEffectM.hs +++ b/Game/LambdaHack/Server/HandleEffectM.hs @@ -1,71 +1,87 @@ {-# LANGUAGE TupleSections #-} --- | Handle effects (most often caused by requests sent by clients). +-- | Handle effects. They are most often caused by requests sent by clients +-- but sometimes also caused by projectiles or periodically activated items. module Game.LambdaHack.Server.HandleEffectM ( applyItem, meleeEffectAndDestroy, effectAndDestroy, itemEffectEmbedded - , dropCStoreItem, dominateFidSfx, pickDroppable, cutCalm + , dropCStoreItem, dominateFidSfx, pickDroppable, refillHP, cutCalm +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , applyMeleeDamage, imperishableKit, itemEffectDisco, effectSem + , effectBurn, effectExplode, effectRefillHP, effectRefillCalm + , effectDominate, dominateFid, effectImpress, effectSummon + , effectAscend, findStairExit, switchLevels1, switchLevels2, effectEscape + , effectParalyze, effectInsertMove, effectTeleport, effectCreateItem + , effectDropItem, allGroupItems, effectPolyItem, effectIdentify, identifyIid + , effectDetect, effectDetectX, effectDetectActor, effectDetectItem + , effectDetectExit, effectDetectHidden + , effectSendFlying, sendFlyingVector, effectDropBestWeapon + , effectActivateInv, effectTransformEqp, effectApplyPerfume, effectOneOf + , effectRecharging, effectTemporary, effectComposite +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Bits (xor) +import Data.Bits (xor) import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.HashMap.Strict as HM -import Data.Key (mapWithKeyM_) +import Data.Int (Int64) +import Data.Key (mapWithKeyM_) -import Game.LambdaHack.Atomic +import Game.LambdaHack.Atomic +import Game.LambdaHack.Client import qualified Game.LambdaHack.Common.Ability as Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemStrongest +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.TileKind as TK -import Game.LambdaHack.Server.CommonM -import Game.LambdaHack.Server.ItemM -import Game.LambdaHack.Server.MonadServer -import Game.LambdaHack.Server.PeriodicM -import Game.LambdaHack.Server.State +import Game.LambdaHack.Server.CommonM +import Game.LambdaHack.Server.ItemM +import Game.LambdaHack.Server.MonadServer +import Game.LambdaHack.Server.PeriodicM +import Game.LambdaHack.Server.ServerOptions +import Game.LambdaHack.Server.State --- + Semantics of effects +-- * Semantics of effects -applyItem :: (MonadAtomic m, MonadServer m) - => ActorId -> ItemId -> CStore -> m () +applyItem :: MonadServerAtomic m => ActorId -> ItemId -> CStore -> m () applyItem aid iid cstore = do execSfxAtomic $ SfxApply aid iid cstore let c = CActor aid cstore meleeEffectAndDestroy aid aid iid c -applyMeleeDamage :: (MonadAtomic m, MonadServer m) +applyMeleeDamage :: MonadServerAtomic m => ActorId -> ActorId -> ItemId -> m Bool applyMeleeDamage source target iid = do itemBase <- getsState $ getItemBody iid - if jdamage itemBase <= 0 then return False else do -- speedup + if jdamage itemBase == 0 then return False else do -- speedup sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target - actorAspect <- getsServer sactorAspect - hurtMult <- getsState $ armorHurtBonus actorAspect source target + ar <- getsState $ getActorAspect target + hurtMult <- getsState $ armorHurtBonus source target dmg <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) $ jdamage itemBase - let ar = actorAspect EM.! target - hpMax = aMaxHP ar + let hpMax = aMaxHP ar rawDeltaHP = fromIntegral hurtMult * xM dmg `divUp` 100 speedDeltaHP = case btrajectory sb of Just (_, speed) -> - modifyDamageBySpeed rawDeltaHP speed @@ -77,22 +93,40 @@ min speedDeltaHP (xM hpMax - bhp tb) | otherwise = speedDeltaHP if deltaHP < 0 then do -- damage the target, never heal - execUpdAtomic $ UpdRefillHP target deltaHP - when serious $ cutCalm target + refillHP serious target tb deltaHP return True else return False +refillHP :: MonadServerAtomic m => Bool -> ActorId -> Actor -> Int64 -> m () +refillHP serious target tbOld deltaHP = do + execUpdAtomic $ UpdRefillHP target deltaHP + when serious $ cutCalm target + -- If leader just lost all HP, change the leader to let players rescue him, + -- especially if he's slowed by the attackers. + tb <- getsState $ getActorBody target + when (bhp tb <= 0 && bhp tbOld > 0) $ do + mleader <- getsState $ gleader . (EM.! bfid tb) . sfactionD + when (Just target == mleader) $ do + actorD <- getsState sactorD + let ours (_, b) = bfid b == bfid tb && not (bproj b) && bhp b > 0 + -- Only consider actors positive HP. + positive = filter ours $ EM.assocs actorD + onLevel <- getsState $ fidActorRegularIds (bfid tb) (blid tb) + case onLevel ++ map fst positive of + [] -> return () + aid : _ -> execUpdAtomic $ UpdLeadFaction (bfid tb) mleader $ Just aid + -- Here melee damage is applied. This is necessary so that the same -- AI benefit calculation may be used for flinging and for applying items. -meleeEffectAndDestroy :: (MonadAtomic m, MonadServer m) - => ActorId -> ActorId -> ItemId -> Container -> m () +meleeEffectAndDestroy :: MonadServerAtomic m + => ActorId -> ActorId -> ItemId -> Container -> m () meleeEffectAndDestroy source target iid c = do meleePerformed <- applyMeleeDamage source target iid bag <- getsState $ getContainerBag c case iid `EM.lookup` bag of Nothing -> error $ "" `showFailure` (source, target, iid, c) Just kit -> do - itemToF <- itemToFullServer + itemToF <- getsState itemToFull let itemFull = itemToF iid kit case itemDisco itemFull of Just ItemDisco {itemKind=IK.ItemKind{IK.ieffects}} -> @@ -100,7 +134,7 @@ itemFull _ -> error $ "" `showFailure` (source, target, iid, c) -effectAndDestroy :: (MonadAtomic m, MonadServer m) +effectAndDestroy :: MonadServerAtomic m => Bool -> ActorId -> ActorId -> ItemId -> Container -> Bool -> [IK.Effect] -> ItemFull -> m () @@ -183,7 +217,7 @@ -- One item of each @iid@ is triggered at once. If there are more copies, -- they are left to be triggered next time. -itemEffectEmbedded :: (MonadAtomic m, MonadServer m) +itemEffectEmbedded :: MonadServerAtomic m => ActorId -> Point -> ItemBag -> m () itemEffectEmbedded aid tpos bag = do sb <- getsState $ getActorBody aid @@ -202,12 +236,12 @@ -- Note that if we activate a durable item, e.g., armor, from the ground, -- it will get identified, which is perfectly fine, until we want to add -- sticky armor that can't be easily taken off (and, e.g., has some maluses). -itemEffectDisco :: (MonadAtomic m, MonadServer m) +itemEffectDisco :: MonadServerAtomic m => ActorId -> ActorId -> ItemId -> Container -> Bool -> Bool -> [IK.Effect] -> m Bool itemEffectDisco source target iid c recharged periodic effs = do - discoKind <- getsServer sdiscoKind + discoKind <- getsState sdiscoKind item <- getsState $ getItemBody iid case EM.lookup (jkindIx item) discoKind of Just KindMean{kmKind} -> do @@ -223,7 +257,7 @@ -- The item may or may not still be in the container. -- The boolean result indicates if the effect actually fired up, -- as opposed to fizzled. -effectSem :: (MonadAtomic m, MonadServer m) +effectSem :: MonadServerAtomic m => ActorId -> ActorId -> ItemId -> Container -> Bool -> Bool -> IK.Effect -> m Bool @@ -274,24 +308,23 @@ IK.Temporary _ -> effectTemporary execSfx source iid c IK.Unique -> return False IK.Periodic -> return False + IK.Composite l -> effectComposite recursiveCall l --- + Individual semantic functions for effects +-- * Individual semantic functions for effects -- ** Burn -- Damage from fire. Not affected by armor. -effectBurn :: (MonadAtomic m, MonadServer m) - => Dice.Dice -> ActorId -> ActorId - -> m Bool +effectBurn :: MonadServerAtomic m + => Dice.Dice -> ActorId -> ActorId -> m Bool effectBurn nDm source target = do tb <- getsState $ getActorBody target - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! target - hpMax = aMaxHP ar + ar <- getsState $ getActorAspect target + let hpMax = aMaxHP ar n <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm let rawDeltaHP = - xM n -- We ignore minor burns. - serious = not (bproj tb) && source /= target && n > 1 + serious = n > 1 && source /= target && not (bproj tb) deltaHP | serious = -- if HP overfull, at least cut back to max HP min rawDeltaHP (xM hpMax - bhp tb) | otherwise = rawDeltaHP @@ -303,13 +336,12 @@ let reportedEffect = IK.Burn $ Dice.intToDice n execSfxAtomic $ SfxEffect (bfid sb) target reportedEffect deltaHP -- Damage the target. - execUpdAtomic $ UpdRefillHP target deltaHP - when serious $ cutCalm target + refillHP serious target tb deltaHP return True -- ** Explode -effectExplode :: (MonadAtomic m, MonadServer m) +effectExplode :: MonadServerAtomic m => m () -> GroupName ItemKind -> ActorId -> m Bool effectExplode execSfx cgroup target = do execSfx @@ -384,21 +416,19 @@ -- ** RefillHP -- Unaffected by armor. -effectRefillHP :: (MonadAtomic m, MonadServer m) - => Int -> ActorId -> ActorId -> m Bool +effectRefillHP :: MonadServerAtomic m => Int -> ActorId -> ActorId -> m Bool effectRefillHP power source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! target - hpMax = aMaxHP ar + ar <- getsState $ getActorAspect target + let hpMax = aMaxHP ar -- We ignore light poison and similar -1HP per turn annoyances. - serious = not (bproj tb) && source /= target && abs power > 1 - deltaHP | power < 0 && serious = -- if overfull, at least cut back to max - min (xM power) (xM hpMax - bhp tb) + serious = power < -1 && source /= target && not (bproj tb) + deltaHP | serious = -- if overfull, at least cut back to max + min (xM power) (xM hpMax - bhp tb) | otherwise = min (xM power) (max 0 $ xM 999 - bhp tb) -- UI limitation - curChalSer <- getsServer $ scurChalSer . sdebugSer + curChalSer <- getsServer $ scurChalSer . soptions fact <- getsState $ (EM.! bfid tb) . sfactionD if | cfish curChalSer && power > 0 && fhasUI (gplayer fact) && bfid sb /= bfid tb -> do @@ -407,16 +437,14 @@ | deltaHP == 0 -> return False | otherwise -> do execSfxAtomic $ SfxEffect (bfid sb) target (IK.RefillHP power) deltaHP - execUpdAtomic $ UpdRefillHP target deltaHP - when (deltaHP < 0 && serious) $ cutCalm target + refillHP serious target tb deltaHP return True -cutCalm :: (MonadAtomic m, MonadServer m) => ActorId -> m () +cutCalm :: MonadServerAtomic m => ActorId -> m () cutCalm target = do tb <- getsState $ getActorBody target - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! target - upperBound = if hpTooLow tb ar + ar <- getsState $ getActorAspect target + let upperBound = if hpTooLow tb ar then 0 -- to trigger domination, etc. else xM $ aMaxCalm ar deltaCalm = min minusM1 (upperBound - bcalm tb) @@ -426,13 +454,12 @@ -- ** RefillCalm -effectRefillCalm :: (MonadAtomic m, MonadServer m) +effectRefillCalm :: MonadServerAtomic m => m () -> Int -> ActorId -> ActorId -> m Bool effectRefillCalm execSfx power source target = do tb <- getsState $ getActorBody target - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! target - calmMax = aMaxCalm ar + ar <- getsState $ getActorAspect target + let calmMax = aMaxCalm ar serious = not (bproj tb) && source /= target && power > 1 deltaCalm | power < 0 && serious = -- if overfull, at least cut to max min (xM power) (xM calmMax - bcalm tb) @@ -446,10 +473,8 @@ -- ** Dominate -effectDominate :: (MonadAtomic m, MonadServer m) - => (IK.Effect -> m Bool) - -> ActorId -> ActorId - -> m Bool +effectDominate :: MonadServerAtomic m + => (IK.Effect -> m Bool) -> ActorId -> ActorId -> m Bool effectDominate recursiveCall source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target @@ -460,22 +485,20 @@ recursiveCall IK.Impress | otherwise -> dominateFidSfx (bfid sb) target -dominateFidSfx :: (MonadAtomic m, MonadServer m) - => FactionId -> ActorId -> m Bool +dominateFidSfx :: MonadServerAtomic m => FactionId -> ActorId -> m Bool dominateFidSfx fid target = do tb <- getsState $ getActorBody target -- Actors that don't move freely can't be dominated, for otherwise, -- when they are the last survivors, they could get stuck -- and the game wouldn't end. - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! target - actorMaxSk = aSkills ar + ar <- getsState $ getActorAspect target + let actorMaxSk = aSkills ar -- Check that the actor can move, also between levels and through doors. -- Otherwise, it's too awkward for human player to control. canMove = EM.findWithDefault 0 Ability.AbMove actorMaxSk > 0 && EM.findWithDefault 0 Ability.AbAlter actorMaxSk >= fromEnum TK.talterForStairs - if canMove && not (bproj tb) then do + if canMove && not (bproj tb) && bhp tb > 0 then do let execSfx = execSfxAtomic $ SfxEffect fid target IK.Dominate 0 execSfx -- if actor ours, possibly the last occasion to see him gameOver <- dominateFid fid target @@ -485,7 +508,7 @@ else return False -dominateFid :: (MonadAtomic m, MonadServer m) => FactionId -> ActorId -> m Bool +dominateFid :: MonadServerAtomic m => FactionId -> ActorId -> m Bool dominateFid fid target = do Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops tb0 <- getsState $ getActorBody target @@ -494,14 +517,13 @@ electLeader (bfid tb0) (blid tb0) target fact <- getsState $ (EM.! bfid tb0) . sfactionD -- Prevent the faction's stash from being lost in case they are not spawners. - when (isNothing $ _gleader fact) $ moveStores False target CSha CInv + when (isNothing $ gleader fact) $ moveStores False target CSha CInv tb <- getsState $ getActorBody target ais <- getsState $ getCarriedAssocs tb - actorAspect <- getsServer sactorAspect + ar <- getsState $ getActorAspect target getItem <- getsState $ flip getItemBody - discoKind <- getsServer sdiscoKind - let ar = actorAspect EM.! target - isImpression iid = case EM.lookup (jkindIx $ getItem iid) discoKind of + discoKind <- getsState sdiscoKind + let isImpression iid = case EM.lookup (jkindIx $ getItem iid) discoKind of Just KindMean{kmKind} -> maybe False (> 0) $ lookup "impressed" $ IK.ifreq (okind kmKind) Nothing -> error $ "" `showFailure` iid @@ -531,7 +553,7 @@ -- Add some nostalgia for the old faction. void $ effectCreateItem (Just $ bfid tb) (Just 10) target COrgan "impressed" IK.TimerNone - itemToF <- itemToFullServer + itemToF <- getsState itemToFull let discoverIf (iid, cstore) = do let itemFull = itemToF iid (1, []) c = CActor target cstore @@ -544,12 +566,12 @@ -- ** Impress -effectImpress :: (MonadAtomic m, MonadServer m) +effectImpress :: MonadServerAtomic m => (IK.Effect -> m Bool) -> m () -> ActorId -> ActorId -> m Bool effectImpress recursiveCall execSfx source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target - if | bproj tb -> return False + if | bproj tb || bhp tb <= 0 -> return False -- avoid spam just before death | bfid tb == bfid sb -> do -- Unimpress wrt others, but only once. res <- recursiveCall $ IK.DropItem 1 1 COrgan "impressed" @@ -563,7 +585,7 @@ -- ** Summon -- Note that the Calm expended doesn't depend on the number of actors summoned. -effectSummon :: (MonadAtomic m, MonadServer m) +effectSummon :: MonadServerAtomic m => m () -> GroupName ItemKind -> Dice.Dice -> ItemId -> ActorId -> ActorId -> Bool -> m Bool @@ -573,7 +595,7 @@ power <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target - actorAspect <- getsServer sactorAspect + actorAspect <- getsState sactorAspect item <- getsState $ getItemBody iid let sar = actorAspect EM.! source tar = actorAspect EM.! target @@ -605,7 +627,7 @@ Nothing -> return False -- not enough space in dungeon? Just aid -> do b <- getsState $ getActorBody aid - mleader <- getsState $ _gleader . (EM.! bfid b) . sfactionD + mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD when (isNothing mleader) $ supplantLeader (bfid b) aid return True return $! or bs @@ -613,7 +635,7 @@ -- ** Ascend -- Note that projectiles can be teleported, too, for extra fun. -effectAscend :: (MonadAtomic m, MonadServer m) +effectAscend :: MonadServerAtomic m => (IK.Effect -> m Bool) -> m () -> Bool -> ActorId -> ActorId -> Point -> m Bool @@ -693,10 +715,10 @@ [] -> error $ "" `showFailure` ps posRes : _ -> return posRes -switchLevels1 :: MonadAtomic m => (ActorId, Actor) -> m (Maybe ActorId) +switchLevels1 :: MonadServerAtomic m => (ActorId, Actor) -> m (Maybe ActorId) switchLevels1 (aid, bOld) = do let side = bfid bOld - mleader <- getsState $ _gleader . (EM.! side) . sfactionD + mleader <- getsState $ gleader . (EM.! side) . sfactionD -- Prevent leader pointing to a non-existing actor. mlead <- if not (bproj bOld) && isJust mleader then do @@ -711,7 +733,7 @@ execUpdAtomic $ UpdLoseActor aid bOld ais return mlead -switchLevels2 ::(MonadAtomic m, MonadServer m) +switchLevels2 ::MonadServerAtomic m => LevelId -> Point -> (ActorId, Actor) -> Time -> Maybe ActorId -> m () switchLevels2 lidNew posNew (aid, bOld) btime_bOld mlead = do @@ -771,7 +793,7 @@ -- ** Escape -- | The faction leaves the dungeon. -effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m Bool +effectEscape :: MonadServerAtomic m => ActorId -> ActorId -> m Bool effectEscape source target = do -- Obvious effect, nothing announced. sb <- getsState $ getActorBody source @@ -791,7 +813,7 @@ -- | Advance target actor time by this many time clips. Not by actor moves, -- to hurt fast actors more. -effectParalyze :: (MonadAtomic m, MonadServer m) +effectParalyze :: MonadServerAtomic m => m () -> Dice.Dice -> ActorId -> m Bool effectParalyze execSfx nDm target = do p <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm @@ -809,14 +831,13 @@ -- | Give target actor the given number of extra moves. Don't give -- an absolute amount of time units, to benefit slow actors more. -effectInsertMove :: (MonadAtomic m, MonadServer m) +effectInsertMove :: MonadServerAtomic m => m () -> Dice.Dice -> ActorId -> m Bool effectInsertMove execSfx nDm target = do execSfx p <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm b <- getsState $ getActorBody target - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! target + ar <- getsState $ getActorAspect target let actorTurn = ticksPerMeter $ bspeed b ar t = timeDeltaScale actorTurn (-p) modifyServer $ \ser -> @@ -827,7 +848,7 @@ -- | Teleport the target actor. -- Note that projectiles can be teleported, too, for extra fun. -effectTeleport :: (MonadAtomic m, MonadServer m) +effectTeleport :: MonadServerAtomic m => m () -> Dice.Dice -> ActorId -> ActorId -> m Bool effectTeleport execSfx nDm source target = do Kind.COps{coTileSpeedup} <- getsState scops @@ -867,7 +888,7 @@ -- ** CreateItem -effectCreateItem :: (MonadAtomic m, MonadServer m) +effectCreateItem :: MonadServerAtomic m => Maybe FactionId -> Maybe Int -> ActorId -> CStore -> GroupName ItemKind -> IK.TimerDice -> m Bool @@ -882,23 +903,20 @@ IK.TimerActorTurn nDm -> do k <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm let !_A = assert (k >= 0) () - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! target - actorTurn = ticksPerMeter $ bspeed tb ar + ar <- getsState $ getActorAspect target + let actorTurn = ticksPerMeter $ bspeed tb ar return $! timeDeltaScale actorTurn k let c = CActor target store bagBefore <- getsState $ getBodyStoreBag tb store let litemFreq = [(grp, 1)] -- Power depth of new items unaffected by number of spawned actors. m5 <- rollItem 0 (blid tb) litemFreq - let (itemKnownRaw, itemFullRaw, itemDisco, seed, _) = + let (itemKnownRaw, itemFullRaw, _, seed, _) = fromMaybe (error $ "" `showFailure` (blid tb, litemFreq, c)) m5 - -- Other code adds to @sdiscoBenefit@ only @iid@ and not any other items - -- that share the same @jkindIx@, so this is broken if such items - -- are not fully IDed from the start, so check that before risking a copy - -- of the same item, but with different @jfid@. + -- Avoid too many different item identifiers (one for each faction) + -- for blasts or common item generating tiles. Temporary organs are + -- also duplicated but they provide really useful info (perpetrator). jfid = if store == COrgan - && IK.Identified `elem` IK.ifeature (itemKind itemDisco) then jfidRaw else Nothing (itemKnown, itemFullFid) = @@ -949,7 +967,7 @@ -- | Make the target actor drop all items in a store from the given group -- (not just a random single item, or cluttering equipment with rubbish -- would be beneficial). -effectDropItem :: (MonadAtomic m, MonadServer m) +effectDropItem :: MonadServerAtomic m => m () -> Int -> Int -> CStore -> GroupName ItemKind -> ActorId -> m Bool effectDropItem execSfx ngroup kcopy store grp target = do @@ -961,12 +979,12 @@ mapM_ (uncurry (dropCStoreItem True store target b kcopy)) $ take ngroup is return True -allGroupItems :: (MonadAtomic m, MonadServer m) +allGroupItems :: MonadServerAtomic m => CStore -> GroupName ItemKind -> ActorId -> m [(ItemId, ItemQuant)] allGroupItems store grp target = do Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops - discoKind <- getsServer sdiscoKind + discoKind <- getsState sdiscoKind b <- getsState $ getActorBody target let hasGroup (iid, _) = do item <- getsState $ getItemBody iid @@ -982,7 +1000,7 @@ -- at most one explodes to avoid excessive carnage and UI clutter -- (let's say, the multiple explosions interfere with each other or perhaps -- larger quantities of explosives tend to be packaged more safely). -dropCStoreItem :: (MonadAtomic m, MonadServer m) +dropCStoreItem :: MonadServerAtomic m => Bool -> CStore -> ActorId -> Actor -> Int -> ItemId -> ItemQuant -> m () @@ -994,7 +1012,7 @@ isDestroyed = bproj b && (bhp b <= 0 && not durable || fragile) || fragile && durable -- hack for tmp organs if isDestroyed then do - itemToF <- itemToFullServer + itemToF <- getsState itemToFull let itemFull = itemToF iid kit effs = strengthOnSmash itemFull -- Activate even if effects null, to destroy the item. @@ -1019,12 +1037,11 @@ -- ** PolyItem -effectPolyItem :: (MonadAtomic m, MonadServer m) - => m () -> ActorId -> ActorId -> m Bool +effectPolyItem :: MonadServerAtomic m => m () -> ActorId -> ActorId -> m Bool effectPolyItem execSfx source target = do sb <- getsState $ getActorBody source let cstore = CGround - allAssocs <- fullAssocsServer target [cstore] + allAssocs <- getsState $ fullAssocs target [cstore] case allAssocs of [] -> do execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxPurposeNothing cstore @@ -1052,38 +1069,41 @@ -- ** Identify -effectIdentify :: (MonadAtomic m, MonadServer m) +effectIdentify :: MonadServerAtomic m => m () -> ItemId -> ActorId -> ActorId -> m Bool effectIdentify execSfx iidId source target = do sb <- getsState $ getActorBody source + s <- getsServer $ (EM.! bfid sb) . sclientStates let tryFull store as = case as of - [] -> do - execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxIdentifyNothing store - return False + [] -> return False (iid, _) : rest | iid == iidId -> tryFull store rest -- don't id itself - (iid, ItemFull{itemDisco=Just ItemDisco{..}}) : rest -> do - -- We avoid identifying trivial items, but they may also be right - -- in the middle of bonus ranges, to if no other option, id them; - -- client will ignore them if really trivial. - let ided = IK.Identified `elem` IK.ifeature itemKind - statsObvious = Just itemAspectMean == itemAspect - if ided && statsObvious && not (null rest) - then tryFull store rest - else do - let c = CActor target store - execSfx - identifyIid iid c itemKindId - return True + (iid, ItemFull{itemBase, itemDisco=Just ItemDisco{..}}) : rest -> + if iid `EM.member` sdiscoAspect s -- already identified + || itemConst -- doesn't need further identification + && jkindIx itemBase `EM.member` sdiscoKind s + || store == CGround + && (not $ any IK.forIdEffect $ IK.ieffects itemKind) + -- will be identified as soon as picked up, so don't bother; + -- darts included, which prevents wasting the scroll + || maybe False (> 0) (lookup "gem" $ IK.ifreq itemKind) -- a hack + then tryFull store rest + else do + let c = CActor target store + execSfx + identifyIid iid c itemKindId + return True _ -> error $ "" `showFailure` (store, as) tryStore stores = case stores of - [] -> return False + [] -> do + execSfxAtomic $ SfxMsgFid (bfid sb) SfxIdentifyNothing + return False store : rest -> do - allAssocs <- fullAssocsServer target [store] + allAssocs <- getsState $ fullAssocs target [store] go <- tryFull store allAssocs if go then return True else tryStore rest - tryStore [CGround] + tryStore [CGround, CEqp, CInv, CSha] -identifyIid :: (MonadAtomic m, MonadServer m) +identifyIid :: MonadServerAtomic m => ItemId -> Container -> Kind.Id ItemKind -> m () identifyIid iid c itemKindId = do seed <- getsServer $ (EM.! iid) . sitemSeedD @@ -1091,11 +1111,11 @@ -- ** Detect -effectDetect :: (MonadAtomic m, MonadServer m) +effectDetect :: MonadServerAtomic m => m () -> Int -> ActorId -> m Bool effectDetect = effectDetectX (const True) (const $ return False) -effectDetectX :: (MonadAtomic m, MonadServer m) +effectDetectX :: MonadServerAtomic m => (Point -> Bool) -> ([Point] -> m Bool) -> m () -> Int -> ActorId -> m Bool effectDetectX predicate action execSfx radius target = do @@ -1133,8 +1153,7 @@ -- ** DetectActor -effectDetectActor :: (MonadAtomic m, MonadServer m) - => m () -> Int -> ActorId -> m Bool +effectDetectActor :: MonadServerAtomic m => m () -> Int -> ActorId -> m Bool effectDetectActor execSfx radius target = do b <- getsState $ getActorBody target Level{lactor} <- getLevel $ blid b @@ -1143,8 +1162,7 @@ -- ** DetectItem -effectDetectItem :: (MonadAtomic m, MonadServer m) - => m () -> Int -> ActorId -> m Bool +effectDetectItem :: MonadServerAtomic m => m () -> Int -> ActorId -> m Bool effectDetectItem execSfx radius target = do b <- getsState $ getActorBody target Level{lfloor} <- getLevel $ blid b @@ -1153,8 +1171,7 @@ -- ** DetectExit -effectDetectExit :: (MonadAtomic m, MonadServer m) - => m () -> Int -> ActorId -> m Bool +effectDetectExit :: MonadServerAtomic m => m () -> Int -> ActorId -> m Bool effectDetectExit execSfx radius target = do b <- getsState $ getActorBody target Level{lstair=(ls1, ls2), lescape} <- getLevel $ blid b @@ -1163,7 +1180,7 @@ -- ** DetectHidden -effectDetectHidden :: (MonadAtomic m, MonadServer m) +effectDetectHidden :: MonadServerAtomic m => m () -> Int -> ActorId -> Point -> m Bool effectDetectHidden execSfx radius target pos = do Kind.COps{coTileSpeedup} <- getsState scops @@ -1171,8 +1188,10 @@ lvl <- getLevel $ blid b let predicate p = Tile.isHideAs coTileSpeedup $ lvl `at` p action l = do - let f p = when (p /= pos) - $ execUpdAtomic $ UpdSearchTile target p $ lvl `at` p + let f p = when (p /= pos) $ do + let t = lvl `at` p + execUpdAtomic $ UpdSearchTile target p t + -- This is safe searching; embedded items are not triggered. mapM_ f l return $! not $ null l effectDetectX predicate action execSfx radius target @@ -1184,9 +1203,8 @@ -- the vector is directed outwards, if no, inwards, if it's the same actor, -- boldpos is used, if it can't, a random outward vector of length 10 -- is picked. -effectSendFlying :: (MonadAtomic m, MonadServer m) - => m () -> IK.ThrowMod - -> ActorId -> ActorId -> Maybe Bool +effectSendFlying :: MonadServerAtomic m + => m () -> IK.ThrowMod -> ActorId -> ActorId -> Maybe Bool -> m Bool effectSendFlying execSfx IK.ThrowMod{..} source target modePush = do v <- sendFlyingVector source target modePush @@ -1208,7 +1226,7 @@ if not $ Tile.isWalkable coTileSpeedup t then return False -- supported by a wall else do - weightAssocs <- fullAssocsServer target [CInv, CEqp, COrgan] + weightAssocs <- getsState $ fullAssocs target [CInv, CEqp, COrgan] let weight = sum $ map (jweight . itemBase . snd) weightAssocs path = bpos tb : pos : rest (trajectory, (speed, range)) = @@ -1229,7 +1247,7 @@ $ sactorTime ser} return True -sendFlyingVector :: (MonadAtomic m, MonadServer m) +sendFlyingVector :: MonadServerAtomic m => ActorId -> ActorId -> Maybe Bool -> m Vector sendFlyingVector source target modePush = do sb <- getsState $ getActorBody source @@ -1260,12 +1278,11 @@ -- ** DropBestWeapon -- | Make the target actor drop his best weapon (stack). -effectDropBestWeapon :: (MonadAtomic m, MonadServer m) - => m () -> ActorId -> m Bool +effectDropBestWeapon :: MonadServerAtomic m => m () -> ActorId -> m Bool effectDropBestWeapon execSfx target = do tb <- getsState $ getActorBody target localTime <- getsState $ getLocalTime (blid tb) - allAssocsRaw <- fullAssocsServer target [CEqp] + allAssocsRaw <- getsState $ fullAssocs target [CEqp] let allAssocs = filter (isMelee . itemBase . snd) allAssocsRaw case strongestMelee Nothing localTime allAssocs of (_, (iid, _)) : _ -> do @@ -1282,14 +1299,13 @@ -- in the target actor's equipment (there's no variant that activates -- a random one, to avoid the incentive for carrying garbage). -- Only one item of each stack is activated (and possibly consumed). -effectActivateInv :: (MonadAtomic m, MonadServer m) - => m () -> ActorId -> Char -> m Bool +effectActivateInv :: MonadServerAtomic m => m () -> ActorId -> Char -> m Bool effectActivateInv execSfx target symbol = effectTransformEqp execSfx target symbol CInv $ \iid _ -> do let c = CActor target CInv meleeEffectAndDestroy target target iid c -effectTransformEqp :: forall m. MonadAtomic m +effectTransformEqp :: forall m. MonadServerAtomic m => m () -> ActorId -> Char -> CStore -> (ItemId -> ItemQuant -> m ()) -> m Bool @@ -1311,8 +1327,7 @@ -- ** ApplyPerfume -effectApplyPerfume :: MonadAtomic m - => m () -> ActorId -> m Bool +effectApplyPerfume :: MonadServerAtomic m => m () -> ActorId -> m Bool effectApplyPerfume execSfx target = do execSfx tb <- getsState $ getActorBody target @@ -1324,10 +1339,8 @@ -- ** OneOf -effectOneOf :: (MonadAtomic m, MonadServer m) - => (IK.Effect -> m Bool) - -> [IK.Effect] - -> m Bool +effectOneOf :: MonadServerAtomic m + => (IK.Effect -> m Bool) -> [IK.Effect] -> m Bool effectOneOf recursiveCall l = do let call1 = do ef <- rndToAction $ oneOf l @@ -1337,13 +1350,12 @@ b <- result if b then return True else callNext foldr f (return False) call99 + -- no @execSfx@, because individual effects sent them -- ** Recharging -effectRecharging :: MonadAtomic m - => (IK.Effect -> m Bool) - -> IK.Effect -> Bool - -> m Bool +effectRecharging :: MonadServerAtomic m + => (IK.Effect -> m Bool) -> IK.Effect -> Bool -> m Bool effectRecharging recursiveCall e recharged = if recharged then recursiveCall e @@ -1351,7 +1363,7 @@ -- ** Temporary -effectTemporary :: MonadAtomic m +effectTemporary :: MonadServerAtomic m => m () -> ActorId -> ItemId -> Container -> m Bool effectTemporary execSfx source iid c = case c of @@ -1364,3 +1376,14 @@ _ -> do execSfx return False -- just a message + +-- ** Composite + +effectComposite :: MonadServerAtomic m + => (IK.Effect -> m Bool) -> [IK.Effect] -> m Bool +effectComposite recursiveCall l = do + let f eff result = do + b <- recursiveCall eff + if b then result >> return True else return False + foldr f (return False) l -- @True@ if any effect triggered + -- no @execSfx@, because individual effects sent them diff --git a/Game/LambdaHack/Server/HandleRequestM.hs b/Game/LambdaHack/Server/HandleRequestM.hs --- a/Game/LambdaHack/Server/HandleRequestM.hs +++ b/Game/LambdaHack/Server/HandleRequestM.hs @@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} --- | Semantics of request. +-- | Semantics of requests +-- . -- A couple of them do not take time, the rest does. -- Note that since the results are atomic commands, which are executed -- only later (on the server and some of the clients), all condition @@ -8,11 +9,11 @@ -- are already issued by the point an expression is evaluated, they do not -- influence the outcome of the evaluation. module Game.LambdaHack.Server.HandleRequestM - ( handleRequestAI, handleRequestUI, switchLeader, handleRequestTimed + ( handleRequestAI, handleRequestUI, handleRequestTimed, switchLeader , reqMove, reqDisplace, reqGameExit #ifdef EXPOSE_INTERNAL -- * Internal operations - , setBWait, handleRequestTimedCases + , setBWait, managePerRequest, handleRequestTimedCases , affectSmell, reqMelee, reqAlter, reqWait , reqMoveItems, reqMoveItem, computeRndTimeout, reqProject, reqApply , reqGameRestart, reqGameSave, reqTactic, reqAutomate @@ -25,44 +26,46 @@ import qualified Data.EnumMap.Strict as EM -import Game.LambdaHack.Atomic +import Game.LambdaHack.Atomic +import Game.LambdaHack.Client import qualified Game.LambdaHack.Common.Ability as Ability -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.TileKind as TK -import Game.LambdaHack.Server.CommonM -import Game.LambdaHack.Server.HandleEffectM -import Game.LambdaHack.Server.ItemM -import Game.LambdaHack.Server.MonadServer -import Game.LambdaHack.Server.PeriodicM -import Game.LambdaHack.Server.State +import Game.LambdaHack.Server.CommonM +import Game.LambdaHack.Server.HandleEffectM +import Game.LambdaHack.Server.ItemM +import Game.LambdaHack.Server.MonadServer +import Game.LambdaHack.Server.PeriodicM +import Game.LambdaHack.Server.ServerOptions +import Game.LambdaHack.Server.State -- | The semantics of server commands. -- AI always takes time and so doesn't loop. -handleRequestAI :: (MonadAtomic m) +handleRequestAI :: MonadServerAtomic m => ReqAI -> m (Maybe RequestAnyAbility) handleRequestAI cmd = case cmd of ReqAITimed cmdT -> return $ Just cmdT ReqAINop -> return Nothing --- | The semantics of server commands. Only the first two cases take time. -handleRequestUI :: (MonadAtomic m, MonadServer m) +-- | The semantics of server commands. Only the first two cases affect time. +handleRequestUI :: MonadServerAtomic m => FactionId -> ActorId -> ReqUI -> m (Maybe RequestAnyAbility) handleRequestUI fid aid cmd = case cmd of @@ -77,35 +80,36 @@ -- | This is a shorthand. Instead of setting @bwait@ in @ReqWait@ -- and unsetting in all other requests, we call this once before -- executing a request. -setBWait :: (MonadAtomic m) => RequestTimed a -> ActorId -> m (Maybe Bool) +setBWait :: MonadServerAtomic m + => RequestTimed a -> ActorId -> Actor -> m (Maybe Bool) {-# INLINE setBWait #-} -setBWait cmd aid = do +setBWait cmd aid b = do let mwait = case cmd of ReqWait -> Just True -- true wait, with bracind, no overhead, etc. ReqWait10 -> Just False -- false wait, only one clip at a time _ -> Nothing - bPre <- getsState $ getActorBody aid - when ((mwait == Just True) /= bwait bPre) $ + when ((mwait == Just True) /= bwait b) $ execUpdAtomic $ UpdWaitActor aid (mwait == Just True) return mwait -handleRequestTimed :: (MonadAtomic m, MonadServer m) +handleRequestTimed :: MonadServerAtomic m => FactionId -> ActorId -> RequestTimed a -> m Bool handleRequestTimed fid aid cmd = do - mwait <- setBWait cmd aid + b <- getsState $ getActorBody aid + mwait <- setBWait cmd aid b -- Note that only the ordinary 1-turn wait eliminates overhead. -- The more fine-graned waits don't make actors braced and induce -- overhead, so that they have some drawbacks in addition to the -- benefit of seeing approaching danger up to almost a turn faster. -- It may be too late to block then, but not too late to sidestep or attack. - unless (mwait == Just True) $ overheadActorTime fid + unless (mwait == Just True) $ overheadActorTime fid (blid b) advanceTime aid (if mwait == Just False then 10 else 100) handleRequestTimedCases aid cmd managePerRequest aid return $! isNothing mwait -- for speed, we report if @cmd@ harmless -- | Clear deltas for Calm and HP for proper UI display and AI hints. -managePerRequest :: MonadAtomic m => ActorId -> m () +managePerRequest :: MonadServerAtomic m => ActorId -> m () managePerRequest aid = do b <- getsState $ getActorBody aid let clearMark = 0 @@ -116,7 +120,7 @@ -- Clear delta for the next player turn. execUpdAtomic $ UpdRefillHP aid clearMark -handleRequestTimedCases :: (MonadAtomic m, MonadServer m) +handleRequestTimedCases :: MonadServerAtomic m => ActorId -> RequestTimed a -> m () handleRequestTimedCases aid cmd = case cmd of ReqMove target -> reqMove aid target @@ -129,13 +133,12 @@ ReqProject p eps iid cstore -> reqProject aid p eps iid cstore ReqApply iid cstore -> reqApply aid iid cstore -switchLeader :: (MonadAtomic m, MonadServer m) - => FactionId -> ActorId -> m () +switchLeader :: MonadServerAtomic m => FactionId -> ActorId -> m () {-# INLINE switchLeader #-} switchLeader fid aidNew = do fact <- getsState $ (EM.! fid) . sfactionD bPre <- getsState $ getActorBody aidNew - let mleader = _gleader fact + let mleader = gleader fact !_A1 = assert (Just aidNew /= mleader && not (bproj bPre) `blame` (aidNew, bPre, fid, fact)) () @@ -174,14 +177,13 @@ -- with gender leave strong and unique enough smell. If smell already there -- and the actor can smell, remove smell. Projectiles are ignored. -- As long as an actor can smell, he doesn't leave any smell ever. -affectSmell :: (MonadAtomic m, MonadServer m) => ActorId -> m () +affectSmell :: MonadServerAtomic m => ActorId -> m () affectSmell aid = do b <- getsState $ getActorBody aid unless (bproj b) $ do fact <- getsState $ (EM.! bfid b) . sfactionD - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! aid - smellRadius = aSmell ar + ar <- getsState $ getActorAspect aid + let smellRadius = aSmell ar when (fhasGender (gplayer fact) || smellRadius > 0) $ do localTime <- getsState $ getLocalTime $ blid b lvl <- getLevel $ blid b @@ -199,7 +201,7 @@ -- Also, only the server is authorized to check if a move is legal -- and it needs full context for that, e.g., the initial actor position -- to check if melee attack does not try to reach to a distant tile. -reqMove :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m () +reqMove :: MonadServerAtomic m => ActorId -> Vector -> m () reqMove source dir = do Kind.COps{coTileSpeedup} <- getsState scops sb <- getsState $ getActorBody source @@ -235,7 +237,7 @@ -- but for melee and not using up the weapon. -- No problem if there are many projectiles at the spot. We just -- attack the one specified. -reqMelee :: (MonadAtomic m, MonadServer m) +reqMelee :: MonadServerAtomic m => ActorId -> ActorId -> ItemId -> CStore -> m () reqMelee source target iid cstore = do sb <- getsState $ getActorBody source @@ -292,7 +294,7 @@ -- or due to a hurled actor colliding with another. -- Don't deduct if no pierce, to prevent spam. when (not (bproj sb2) || bhp sb2 > oneM) $ - execUpdAtomic $ UpdRefillHP source minusM + refillHP False source sb2 minusM when (not (bproj sb2) || bhp sb2 <= oneM) $ -- Non-projectiles can't pierce, so terminate their flight. -- If projectile has too low HP to pierce, ditto. @@ -312,7 +314,7 @@ -- * ReqDisplace -- | Actor tries to swap positions with another. -reqDisplace :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m () +reqDisplace :: MonadServerAtomic m => ActorId -> ActorId -> m () reqDisplace source target = do Kind.COps{coTileSpeedup} <- getsState scops sb <- getsState $ getActorBody source @@ -322,8 +324,7 @@ adj = checkAdjacent sb tb atWar = isAtWar tfact (bfid sb) req = ReqDisplace target - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! target + ar <- getsState $ getActorAspect target dEnemy <- getsState $ dispEnemy source target $ aSkills ar if | not adj -> execFailure source req DisplaceDistant | atWar && not dEnemy -> do -- if not at war, can displace always @@ -359,100 +360,153 @@ -- * ReqAlter -- | Search and/or alter the tile. --- --- Note that if @serverTile /= freshClientTile@, @freshClientTile@ --- should not be alterable (but @serverTile@ may be). -reqAlter :: (MonadAtomic m, MonadServer m) => ActorId -> Point -> m () +reqAlter :: MonadServerAtomic m => ActorId -> Point -> m () reqAlter source tpos = do - Kind.COps{cotile=Kind.Ops{okind, opick}, coTileSpeedup} <- getsState scops + Kind.COps{ cotile=cotile@Kind.Ops{okind, opick} + , coTileSpeedup } <- getsState scops sb <- getsState $ getActorBody source + sClient <- getsServer $ (EM.! bfid sb) . sclientStates actorSk <- currentSkillsServer source let alterSkill = EM.findWithDefault 0 Ability.AbAlter actorSk lid = blid sb - spos = bpos sb req = ReqAlter tpos + embeds <- getsState $ getEmbedBag lid tpos lvl <- getLevel lid let serverTile = lvl `at` tpos - hidden = Tile.isHideAs coTileSpeedup serverTile - -- Only actors with AbAlter > 1 can search for hidden doors, etc. - if alterSkill <= 1 - || not hidden -- no searching needed - && alterSkill < Tile.alterMinSkill coTileSpeedup serverTile - then execFailure source req AlterUnskilled - else if not $ adjacent spos tpos then execFailure source req AlterDistant - else do - let changeTo tgroup = do - -- No @SfxAlter@, because the effect is obvious (e.g., opened door). - let nightCond kt = not (Tile.kindHasFeature TK.Walkable kt - && Tile.kindHasFeature TK.Clear kt) - || (if lnight lvl then id else not) - (Tile.kindHasFeature TK.Dark kt) - -- Sometimes the tile is determined precisely by the ambient light - -- of the source tiles. If not, default to cave day/night condition. - mtoTile <- rndToAction $ opick tgroup nightCond - toTile <- maybe (rndToAction - $ fromMaybe (error $ "" `showFailure` tgroup) - <$> opick tgroup (const True)) - return - mtoTile - unless (toTile == serverTile) $ do - execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile - case (Tile.isExplorable coTileSpeedup serverTile, - Tile.isExplorable coTileSpeedup toTile) of - (False, True) -> execUpdAtomic $ UpdAlterExplorable lid 1 - (True, False) -> execUpdAtomic $ UpdAlterExplorable lid (-1) - _ -> return () - feats = TK.tfeature $ okind serverTile - toAlter feat = - case feat of - TK.OpenTo tgroup -> Just tgroup - TK.CloseTo tgroup -> Just tgroup - TK.ChangeTo tgroup -> Just tgroup - _ -> Nothing - groupsToAlterTo = mapMaybe toAlter feats - embeds <- getsState $ getEmbedBag lid tpos - if null groupsToAlterTo && null embeds && not hidden then - -- Neither searching nor altering possible; silly client. - execFailure source req AlterNothing - else - if EM.notMember tpos $ lfloor lvl then - if null (posToAidsLvl tpos lvl) then do - when hidden $ - -- Search, in case some actors present (e.g., of other factions) - -- don't know this tile. - execUpdAtomic $ UpdSearchTile source tpos serverTile - when (alterSkill >= Tile.alterMinSkill coTileSpeedup serverTile) $ do + lvlClient = (EM.! lid) . sdungeon $ sClient + clientTile = lvlClient `at` tpos + hiddenTile = Tile.hideAs cotile serverTile + revealEmbed = unless (null embeds) $ do + s <- getState + let ais = map (\iid -> (iid, getItemBody iid s)) (EM.keys embeds) + execUpdAtomic $ UpdSpotItemBag (CEmbed lid tpos) embeds ais + if not $ adjacent (bpos sb) tpos then execFailure source req AlterDistant + else if Just clientTile == hiddenTile then -- searches + -- Only actors with AbAlter > 1 can search for hidden doors, etc. + if alterSkill <= 1 + then execFailure source req AlterUnskilled -- don't leak about searching + else do + -- Blocking by items nor actors does not prevent searching. + -- Searching broadcasted, in case actors from other factions are present + -- so that they can learn the tile and learn our action. + -- If they already know the tile, they will just consider our action + -- a waste of time and ignore the command. + execUpdAtomic $ UpdSearchTile source tpos serverTile + -- Searching also reveals the embedded items of the tile. + -- If the items are already seen by the client + -- (e.g., due to item detection, despite tile being still hidden), + -- the command is ignored on the client. + revealEmbed + -- Seaching triggers the embeds as well, after they are revealed. + -- The rationale is that the items were all the time present + -- (just invisible to the client), so they need to be triggered. + -- The exception is changable tiles, because they are not so easy + -- to trigger; they need subsequent altering. + unless (Tile.isDoor coTileSpeedup serverTile + || Tile.isChangable coTileSpeedup serverTile) $ + itemEffectEmbedded source tpos embeds + else if clientTile == serverTile then -- alters + if alterSkill < Tile.alterMinSkill coTileSpeedup serverTile + then execFailure source req AlterUnskilled -- don't leak about altering + else do + let changeTo tgroup = do + lvl2 <- getLevel lid + -- No @SfxAlter@, because the effect is obvious (e.g., opened door). + let nightCond kt = not (Tile.kindHasFeature TK.Walkable kt + && Tile.kindHasFeature TK.Clear kt) + || (if lnight lvl2 then id else not) + (Tile.kindHasFeature TK.Dark kt) + -- Sometimes the tile is determined precisely by the ambient light + -- of the source tiles. If not, default to cave day/night condition. + mtoTile <- rndToAction $ opick tgroup nightCond + toTile <- maybe (rndToAction + $ fromMaybe (error $ "" `showFailure` tgroup) + <$> opick tgroup (const True)) + return + mtoTile + unless (toTile == serverTile) $ do + -- At most one of these two will be accepted on any given client. + execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile + -- This case happens when a client does not see a searching + -- action by another faction, but sees the subsequent altering. + case hiddenTile of + Just tHidden -> + execUpdAtomic $ UpdAlterTile lid tpos tHidden toTile + Nothing -> return () + case (Tile.isExplorable coTileSpeedup serverTile, + Tile.isExplorable coTileSpeedup toTile) of + (False, True) -> execUpdAtomic $ UpdAlterExplorable lid 1 + (True, False) -> execUpdAtomic $ UpdAlterExplorable lid (-1) + _ -> return () + -- At the end we replace old embeds (even if partially used up) + -- with new ones. + -- If the source tile was hidden, the items could not be visible + -- on a client, in which case the command would be ignored + -- on the client, without causing any problems. Otherwise, + -- if the position is in view, client has accurate info. + case EM.lookup tpos (lembed lvl2) of + Just bag -> do + s <- getState + let ais = map (\iid -> (iid, getItemBody iid s)) (EM.keys bag) + execUpdAtomic $ UpdLoseItemBag (CEmbed lid tpos) bag ais + Nothing -> return () + -- Altering always reveals the outcome tile, so it's not hidden + -- and so its embedded items are always visible. + embedItem lid tpos toTile + feats = TK.tfeature $ okind serverTile + toAlter feat = + case feat of + TK.OpenTo tgroup -> Just tgroup + TK.CloseTo tgroup -> Just tgroup + TK.ChangeTo tgroup -> Just tgroup + _ -> Nothing + groupsToAlterTo = mapMaybe toAlter feats + if null groupsToAlterTo && null embeds then + -- No altering possible; silly client. + execFailure source req AlterNothing + else + if EM.notMember tpos $ lfloor lvl then + if null (posToAidsLvl tpos lvl) then do + -- The embeds of the initial tile are activated before the tile + -- is altered. This prevents, e.g., trying to activate items + -- where none are present any more, or very different to what + -- the client expected. Surprise only comes through searching above. + -- The items are first revealed for the sake of clients that + -- may see the tile as hidden. Note that the tile is not revealed + -- (unless it's altered later on, in which case the new one is). + revealEmbed + itemEffectEmbedded source tpos embeds case groupsToAlterTo of [] -> return () [groupToAlterTo] -> changeTo groupToAlterTo l -> error $ "tile changeable in many ways" `showFailure` l - itemEffectEmbedded source tpos embeds - else execFailure source req AlterBlockActor - else execFailure source req AlterBlockItem + else execFailure source req AlterBlockActor + else execFailure source req AlterBlockItem + else -- client is misguided re tile at that position, so bail out + execFailure source req AlterNothing -- * ReqWait -- | Do nothing. -- -- Something is sometimes done in 'setBWait'. -reqWait :: MonadAtomic m => ActorId -> m () +reqWait :: MonadServerAtomic m => ActorId -> m () {-# INLINE reqWait #-} reqWait _ = return () -- * ReqMoveItems -reqMoveItems :: (MonadAtomic m, MonadServer m) +reqMoveItems :: MonadServerAtomic m => ActorId -> [(ItemId, Int, CStore, CStore)] -> m () reqMoveItems aid l = do b <- getsState $ getActorBody aid - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! aid + ar <- getsState $ getActorAspect aid -- Server accepts item movement based on calm at the start, not end -- or in the middle, to avoid interrupted or partially ignored commands. - calmE = calmEnough b ar + let calmE = calmEnough b ar mapM_ (reqMoveItem aid calmE) l -reqMoveItem :: (MonadAtomic m, MonadServer m) +reqMoveItem :: MonadServerAtomic m => ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m () reqMoveItem aid calmE (iid, k, fromCStore, toCStore) = do b <- getsState $ getActorBody aid @@ -469,7 +523,7 @@ | (fromCStore == CSha || toCStore == CSha) && not calmE -> execFailure aid req ItemNotCalm | otherwise -> do - itemToF <- itemToFullServer + itemToF <- getsState itemToFull let itemFull = itemToF iid (k, []) when (fromCStore == CGround) $ discoverIfNoEffects fromC iid itemFull upds <- generalMoveItem True iid k fromC toC @@ -522,7 +576,7 @@ -- * ReqProject -reqProject :: (MonadAtomic m, MonadServer m) +reqProject :: MonadServerAtomic m => ActorId -- ^ actor projecting the item (is on current lvl) -> Point -- ^ target position of the projectile -> Int -- ^ digital line parameter @@ -532,9 +586,8 @@ reqProject source tpxy eps iid cstore = do let req = ReqProject tpxy eps iid cstore b <- getsState $ getActorBody source - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! source - calmE = calmEnough b ar + ar <- getsState $ getActorAspect source + let calmE = calmEnough b ar if cstore == CSha && not calmE then execFailure source req ItemNotCalm else do mfail <- projectFail source tpxy eps iid cstore False @@ -542,7 +595,7 @@ -- * ReqApply -reqApply :: (MonadAtomic m, MonadServer m) +reqApply :: MonadServerAtomic m => ActorId -- ^ actor applying the item (is on current level) -> ItemId -- ^ the item to be applied -> CStore -- ^ the location of the item @@ -550,16 +603,15 @@ reqApply aid iid cstore = do let req = ReqApply iid cstore b <- getsState $ getActorBody aid - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! aid - calmE = calmEnough b ar + ar <- getsState $ getActorAspect aid + let calmE = calmEnough b ar if cstore == CSha && not calmE then execFailure aid req ItemNotCalm else do bag <- getsState $ getBodyStoreBag b cstore case EM.lookup iid bag of Nothing -> execFailure aid req ApplyOutOfReach Just kit -> do - itemToF <- itemToFullServer + itemToF <- getsState itemToFull actorSk <- currentSkillsServer aid localTime <- getsState $ getLocalTime (blid b) let skill = EM.findWithDefault 0 Ability.AbApply actorSk @@ -571,11 +623,11 @@ -- * ReqGameRestart -reqGameRestart :: (MonadAtomic m, MonadServer m) +reqGameRestart :: MonadServerAtomic m => ActorId -> GroupName ModeKind -> Challenge -> m () reqGameRestart aid groupName scurChalSer = do - modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {scurChalSer}} + modifyServer $ \ser -> ser {soptionsNxt = (soptionsNxt ser) {scurChalSer}} b <- getsState $ getActorBody aid oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD modifyServer $ \ser -> @@ -590,7 +642,7 @@ -- * ReqGameExit -reqGameExit :: (MonadAtomic m, MonadServer m) => ActorId -> m () +reqGameExit :: MonadServerAtomic m => ActorId -> m () reqGameExit aid = do b <- getsState $ getActorBody aid oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD @@ -608,12 +660,12 @@ -- * ReqTactic -reqTactic :: MonadAtomic m => FactionId -> Tactic -> m () +reqTactic :: MonadServerAtomic m => FactionId -> Tactic -> m () reqTactic fid toT = do fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD execUpdAtomic $ UpdTacticFaction fid toT fromT -- * ReqAutomate -reqAutomate :: MonadAtomic m => FactionId -> m () +reqAutomate :: MonadServerAtomic m => FactionId -> m () reqAutomate fid = execUpdAtomic $ UpdAutoFaction fid True diff --git a/Game/LambdaHack/Server/ItemM.hs b/Game/LambdaHack/Server/ItemM.hs --- a/Game/LambdaHack/Server/ItemM.hs +++ b/Game/LambdaHack/Server/ItemM.hs @@ -1,8 +1,11 @@ -- | Server operations for items. module Game.LambdaHack.Server.ItemM - ( rollItem, rollAndRegisterItem, registerItem - , placeItemsInDungeon, embedItemsInDungeon, fullAssocsServer - , itemToFullServer, mapActorCStore_ + ( registerItem, embedItem, rollItem, rollAndRegisterItem + , placeItemsInDungeon, embedItemsInDungeon, mapActorCStore_ +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , onlyRegisterItem, createLevelItem +#endif ) where import Prelude () @@ -11,30 +14,31 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Function +import Data.Function import qualified Data.HashMap.Strict as HM -import Data.Ord +import Data.Ord -import Game.LambdaHack.Atomic -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Atomic +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.TileKind (TileKind) -import Game.LambdaHack.Server.ItemRev -import Game.LambdaHack.Server.MonadServer -import Game.LambdaHack.Server.State +import Game.LambdaHack.Content.TileKind (TileKind) +import Game.LambdaHack.Server.ItemRev +import Game.LambdaHack.Server.MonadServer +import Game.LambdaHack.Server.ServerOptions +import Game.LambdaHack.Server.State -onlyRegisterItem :: (MonadAtomic m, MonadServer m) +onlyRegisterItem :: MonadServerAtomic m => ItemKnown -> ItemSeed -> m ItemId onlyRegisterItem itemKnown@(_, aspectRecord, _, _) seed = do itemRev <- getsServer sitemRev @@ -42,21 +46,23 @@ Just iid -> return iid Nothing -> do icounter <- getsServer sicounter + executedOnServer <- + execUpdAtomicSer $ UpdDiscoverServer icounter aspectRecord + let !_A = assert executedOnServer () modifyServer $ \ser -> - ser { sdiscoAspect = EM.insert icounter aspectRecord (sdiscoAspect ser) - , sitemSeedD = EM.insert icounter seed (sitemSeedD ser) + ser { sitemSeedD = EM.insert icounter seed (sitemSeedD ser) , sitemRev = HM.insert itemKnown icounter (sitemRev ser) , sicounter = succ icounter } return $! icounter -registerItem :: (MonadAtomic m, MonadServer m) +registerItem :: MonadServerAtomic m => ItemFull -> ItemKnown -> ItemSeed -> Container -> Bool -> m ItemId registerItem ItemFull{..} itemKnown seed container verbose = do iid <- onlyRegisterItem itemKnown seed let cmd = if verbose then UpdCreateItem else UpdSpotItem False execUpdAtomic $ cmd iid itemBase (itemK, itemTimer) container - knowItems <- getsServer $ sknowItems . sdebugSer + knowItems <- getsServer $ sknowItems . soptions when knowItems $ case container of CTrunk{} -> return () _ -> do @@ -64,13 +70,13 @@ execUpdAtomic $ UpdDiscover container iid itemKindId seed return iid -createLevelItem :: (MonadAtomic m, MonadServer m) => Point -> LevelId -> m () +createLevelItem :: MonadServerAtomic m => Point -> LevelId -> m () createLevelItem pos lid = do Level{litemFreq} <- getLevel lid let container = CFloor lid pos void $ rollAndRegisterItem lid litemFreq container True Nothing -embedItem :: (MonadAtomic m, MonadServer m) +embedItem :: MonadServerAtomic m => LevelId -> Point -> Kind.Id TileKind -> m () embedItem lid pos tk = do Kind.COps{cotile} <- getsState scops @@ -79,14 +85,14 @@ f grp = rollAndRegisterItem lid [(grp, 1)] container False Nothing mapM_ f embeds -rollItem :: (MonadAtomic m, MonadServer m) +rollItem :: MonadServerAtomic m => Int -> LevelId -> Freqs ItemKind -> m (Maybe ( ItemKnown, ItemFull, ItemDisco , ItemSeed, GroupName ItemKind )) rollItem lvlSpawned lid itemFreq = do cops <- getsState scops flavour <- getsServer sflavour - disco <- getsServer sdiscoKind + disco <- getsState sdiscoKind discoRev <- getsServer sdiscoKindRev uniqueSet <- getsServer suniqueSet totalDepth <- getsState stotalDepth @@ -101,7 +107,7 @@ _ -> return () return m5 -rollAndRegisterItem :: (MonadAtomic m, MonadServer m) +rollAndRegisterItem :: MonadServerAtomic m => LevelId -> Freqs ItemKind -> Container -> Bool -> Maybe Int -> m (Maybe (ItemId, (ItemFull, GroupName ItemKind))) @@ -115,7 +121,7 @@ iid <- registerItem itemFull itemKnown seed container verbose return $ Just (iid, (itemFull, itemGroup)) -placeItemsInDungeon :: forall m. (MonadAtomic m, MonadServer m) => m () +placeItemsInDungeon :: forall m. MonadServerAtomic m => m () placeItemsInDungeon = do Kind.COps{coTileSpeedup} <- getsState scops let initialItems (lid, Level{ltile, litemNum, lxsize, lysize}) = do @@ -145,7 +151,7 @@ fromEasyToHard = sortBy (comparing absLid `on` fst) $ EM.assocs dungeon mapM_ initialItems fromEasyToHard -embedItemsInDungeon :: (MonadAtomic m, MonadServer m) => m () +embedItemsInDungeon :: MonadServerAtomic m => m () embedItemsInDungeon = do let embedItems (lid, Level{ltile}) = PointArray.imapMA_ (embedItem lid) ltile dungeon <- getsState sdungeon @@ -154,24 +160,6 @@ let absLid = abs . fromEnum fromEasyToHard = sortBy (comparing absLid `on` fst) $ EM.assocs dungeon mapM_ embedItems fromEasyToHard - -fullAssocsServer :: MonadServer m - => ActorId -> [CStore] -> m [(ItemId, ItemFull)] -fullAssocsServer aid cstores = do - cops <- getsState scops - discoKind <- getsServer sdiscoKind - discoAspect <- getsServer sdiscoAspect - getsState $ fullAssocs cops discoKind discoAspect aid cstores - -itemToFullServer :: MonadServer m => m (ItemId -> ItemQuant -> ItemFull) -itemToFullServer = do - cops <- getsState scops - discoKind <- getsServer sdiscoKind - discoAspect <- getsServer sdiscoAspect - s <- getState - let itemToF iid = - itemToFull cops discoKind discoAspect iid (getItemBody iid s) - return itemToF -- | Mapping over actor's items from a give store. mapActorCStore_ :: MonadServer m diff --git a/Game/LambdaHack/Server/ItemRev.hs b/Game/LambdaHack/Server/ItemRev.hs --- a/Game/LambdaHack/Server/ItemRev.hs +++ b/Game/LambdaHack/Server/ItemRev.hs @@ -1,10 +1,10 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | Server types and operations for items that don't involve server state --- nor our custom monads. +-- | Creation of items on the server. Types and operations that don't involve +-- server state nor our custom monads. module Game.LambdaHack.Server.ItemRev - ( ItemKnown, ItemRev, buildItem, newItem, UniqueSet + ( ItemKnown, ItemRev, UniqueSet, buildItem, newItem -- * Item discovery types - , DiscoveryKindRev, serverDiscos, ItemSeedDict + , DiscoveryKindRev, ItemSeedDict, serverDiscos -- * The @FlavourMap@ type , FlavourMap, emptyFlavourMap, dungeonFlavourMap ) where @@ -13,49 +13,41 @@ import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.HashMap.Strict as HM import qualified Data.Set as S import qualified Game.LambdaHack.Common.Dice as Dice -import Game.LambdaHack.Common.Flavour -import Game.LambdaHack.Common.Frequency -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Flavour +import Game.LambdaHack.Common.Frequency +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK --- | The reverse map to @DiscoveryKind@, needed for item creation. -type DiscoveryKindRev = EM.EnumMap (Kind.Id ItemKind) ItemKindIx +-- | The essential item properties, used for the @ItemRev@ hash table +-- from items to their ids, needed to assign ids to newly generated items. +-- All the other meaningul properties can be derived from them. +-- Note 1: @jlid@ is not meaningful; it gets forgotten if items from +-- different levels roll the same random properties and so are merged. +-- However, the first item generated by the server wins, which is most +-- of the time the lower @jlid@ item, which makes sense for the client. +-- Note 2: @ItemSeed@ instead of @AspectRecord@ is not enough, +-- becaused different seeds may result in the same @AspectRecord@ +-- and we don't want such items to be distinct in UI and elsewhere. +type ItemKnown = (ItemKindIx, AspectRecord, Dice.Dice, Maybe FactionId) --- | The map of item ids to item seeds, needed for item creation. -type ItemSeedDict = EM.EnumMap ItemId ItemSeed +-- | Reverse item map, for item creation, to keep items and item identifiers +-- in bijection. +type ItemRev = HM.HashMap ItemKnown ItemId type UniqueSet = ES.EnumSet (Kind.Id ItemKind) -serverDiscos :: Kind.COps -> Rnd (DiscoveryKind, DiscoveryKindRev) -serverDiscos Kind.COps{coitem=Kind.Ops{olength, ofoldlWithKey', okind}} = do - let ixs = [toEnum 0..toEnum (olength-1)] - shuffle :: Eq a => [a] -> Rnd [a] - shuffle [] = return [] - shuffle l = do - x <- oneOf l - (x :) <$> shuffle (delete x l) - shuffled <- shuffle ixs - let f (!ikMap, !ikRev, ix : rest) kmKind _ = - let kmMean = meanAspect $ okind kmKind - in (EM.insert ix KindMean{..} ikMap, EM.insert kmKind ix ikRev, rest) - f (ikMap, _, []) ik _ = - error $ "too short ixs" `showFailure` (ik, ikMap) - (discoS, discoRev, _) = - ofoldlWithKey' f (EM.empty, EM.empty, shuffled) - return (discoS, discoRev) - -- | Build an item with the given stats. buildItem :: FlavourMap -> DiscoveryKindRev -> Kind.Id ItemKind -> ItemKind -> LevelId -> Dice.Dice @@ -122,11 +114,11 @@ itemK = max 1 itemN itemTimer = [timeZero | IK.Periodic `elem` IK.ieffects itemKind] -- delay first discharge of single organs - itemAspectMean = - kmMean $ EM.findWithDefault (error $ "" `showFailure` kindIx) - kindIx disco - itemDiscoData = ItemDisco { itemKindId, itemKind, itemAspectMean - , itemAspect = Just aspectRecord } + km = EM.findWithDefault (error $ "" `showFailure` kindIx) kindIx disco + itemAspectMean = kmMean km + itemConst = kmConst km + itemAspect = Just aspectRecord + itemDiscoData = ItemDisco {..} itemDisco = Just itemDiscoData -- Bonuses on items/actors unaffected by number of spawned actors. aspectRecord = seedToAspect seed itemKind ldepth totalDepth @@ -137,6 +129,32 @@ , seed , itemGroup ) +-- | The reverse map to @DiscoveryKind@, needed for item creation. +type DiscoveryKindRev = EM.EnumMap (Kind.Id ItemKind) ItemKindIx + +-- | The map of item ids to item seeds, needed for item creation. +type ItemSeedDict = EM.EnumMap ItemId ItemSeed + +serverDiscos :: Kind.COps -> Rnd (DiscoveryKind, DiscoveryKindRev) +serverDiscos Kind.COps{coitem=Kind.Ops{olength, ofoldlWithKey', okind}} = do + let ixs = [toEnum 0..toEnum (olength-1)] + shuffle :: Eq a => [a] -> Rnd [a] + shuffle [] = return [] + shuffle l = do + x <- oneOf l + (x :) <$> shuffle (delete x l) + shuffled <- shuffle ixs + let f (!ikMap, !ikRev, ix : rest) kmKind _ = + let kind = okind kmKind + kmMean = meanAspect kind + kmConst = not $ aspectsRandom kind + in (EM.insert ix KindMean{..} ikMap, EM.insert kmKind ix ikRev, rest) + f (ikMap, _, []) ik _ = + error $ "too short ixs" `showFailure` (ik, ikMap) + (discoS, discoRev, _) = + ofoldlWithKey' f (EM.empty, EM.empty, shuffled) + return (discoS, discoRev) + -- | Flavours assigned by the server to item kinds, in this particular game. newtype FlavourMap = FlavourMap (EM.EnumMap (Kind.Id ItemKind) Flavour) deriving (Show, Binary) @@ -175,19 +193,3 @@ liftM (FlavourMap . fst) $ ofoldlWithKey' (rollFlavourMap (S.fromList stdFlav)) (return (EM.empty, EM.empty)) - --- | Reverse item map, for item creation, to keep items and item identifiers --- in bijection. -type ItemRev = HM.HashMap ItemKnown ItemId - --- | The essential item properties, used for the @ItemRev@ hash table --- from items to their ids, needed to assign ids to newly generated items. --- All the other meaningul properties can be derived from them. --- Note 1: @jlid@ is not meaningful; it gets forgotten if items from --- different levels roll the same random properties and so are merged. --- However, the first item generated by the server wins, which is most --- of the time the lower @jlid@ item, which makes sense for the client. --- Note 2: @ItemSeed@ instead of @AspectRecord@ is not enough, --- becaused different seeds may result in the same @AspectRecord@ --- and we don't want such items to be distinct in UI and elsewhere. -type ItemKnown = (ItemKindIx, AspectRecord, Dice.Dice, Maybe FactionId) diff --git a/Game/LambdaHack/Server/LoopM.hs b/Game/LambdaHack/Server/LoopM.hs --- a/Game/LambdaHack/Server/LoopM.hs +++ b/Game/LambdaHack/Server/LoopM.hs @@ -6,9 +6,9 @@ #ifdef EXPOSE_INTERNAL -- * Internal operations , factionArena, arenasForLoop, handleFidUpd, loopUpd, endClip - , applyPeriodicLevel - , handleTrajectories, hTrajectories, handleActors, hActors - , gameExit, restartGame, writeSaveAll, setTrajectory + , manageCalmAndDomination, applyPeriodicLevel + , handleTrajectories, hTrajectories, setTrajectory + , handleActors, hActors, restartGame #endif ) where @@ -20,73 +20,80 @@ import qualified Data.EnumSet as ES import qualified Data.Ord as Ord -import Game.LambdaHack.Atomic -import Game.LambdaHack.Client (Config, SessionUI) -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.ClientOptions -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemStrongest +import Game.LambdaHack.Atomic +import Game.LambdaHack.Client +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.Response -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Server.EndM -import Game.LambdaHack.Server.Fov -import Game.LambdaHack.Server.HandleEffectM -import Game.LambdaHack.Server.HandleRequestM -import Game.LambdaHack.Server.ItemM -import Game.LambdaHack.Server.MonadServer -import Game.LambdaHack.Server.PeriodicM -import Game.LambdaHack.Server.ProtocolM -import Game.LambdaHack.Server.StartM -import Game.LambdaHack.Server.State +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.RuleKind +import Game.LambdaHack.Server.CommonM +import Game.LambdaHack.Server.EndM +import Game.LambdaHack.Server.HandleEffectM +import Game.LambdaHack.Server.HandleRequestM +import Game.LambdaHack.Server.MonadServer +import Game.LambdaHack.Server.PeriodicM +import Game.LambdaHack.Server.ProtocolM +import Game.LambdaHack.Server.ServerOptions +import Game.LambdaHack.Server.StartM +import Game.LambdaHack.Server.State -- | Start a game session, including the clients, and then loop, -- communicating with the clients. -loopSer :: (MonadAtomic m, MonadServerReadRequest m) - => DebugModeSer -- ^ server debug parameters - -> Config - -> (Maybe SessionUI -> FactionId -> ChanServer -> IO ()) - -- ^ the code to run for UI clients +-- +-- The loop is started in server state that is empty, see 'emptyStateServer'. +loopSer :: (MonadServerAtomic m, MonadServerReadRequest m) + => ServerOptions + -- ^ player-supplied server options + -> (Bool -> FactionId -> ChanServer -> IO ()) + -- ^ function that initializes a client and runs its main loop -> m () -loopSer sdebug sconfig executorClient = do +loopSer serverOptions executorClient = do -- Recover states and launch clients. + modifyServer $ \ser -> ser { soptionsNxt = serverOptions + , soptions = serverOptions } cops <- getsState scops - let updConn = updateConn sconfig executorClient - restored <- tryRestore cops sdebug + let updConn = updateConn executorClient + restored <- tryRestore case restored of - Just (sRaw, ser) | not $ snewGameSer sdebug -> do -- a restored game + Just (sRaw, ser) | not $ snewGameSer serverOptions -> do -- a restored game execUpdAtomic $ UpdResumeServer $ updateCOps (const cops) sRaw - putServer ser - modifyServer $ \ser2 -> ser2 {sdebugNxt = sdebug} + putServer ser {soptionsNxt = serverOptions} applyDebug + factionD <- getsState sfactionD + let f fid = let cmd = UpdResumeServer $ updateCOps (const cops) + $ sclientStates ser EM.! fid + in execUpdAtomicFidCatch fid cmd + mapM_ f $ EM.keys factionD updConn initPer pers <- getsServer sperFid - factionD <- getsState sfactionD mapM_ (\fid -> sendUpdate fid $ UpdResume fid (pers EM.! fid)) (EM.keys factionD) - -- We dump RNG seeds here, in case the game wasn't run - -- with --dumpInitRngs previously and we need the seeds. + -- We dump RNG seeds here, based on @soptionsNxt@, in case the game + -- wasn't run with @--dumpInitRngs@ previously, but we need the seeds, + -- e.g., to diagnose a crash. rngs <- getsServer srngs - when (sdumpInitRngs sdebug) $ dumpRngs rngs + when (sdumpInitRngs serverOptions) $ dumpRngs rngs _ -> do -- starting new game for this savefile (--newGame or fresh save) - s <- gameReset cops sdebug Nothing Nothing -- get RNG from item boost - -- Set up commandline debug mode. - let debugBarRngs = sdebug {sdungeonRng = Nothing, smainRng = Nothing} - modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs - , sdebugSer = debugBarRngs } + s <- gameReset serverOptions Nothing Nothing + -- get RNG from item boost + -- Set up commandline options. + let optionsBarRngs = + serverOptions {sdungeonRng = Nothing, smainRng = Nothing} + modifyServer $ \ser -> ser { soptionsNxt = optionsBarRngs + , soptions = optionsBarRngs } execUpdAtomic $ UpdRestartServer s updConn initPer @@ -95,7 +102,7 @@ loopUpd updConn factionArena :: MonadStateRead m => Faction -> m (Maybe LevelId) -factionArena fact = case _gleader fact of +factionArena fact = case gleader fact of -- Even spawners need an active arena for their leader, -- or they start clogging stairs. Just leader -> do @@ -117,7 +124,7 @@ `swith` factionD) () return $! arenas -handleFidUpd :: (MonadAtomic m, MonadServerReadRequest m) +handleFidUpd :: (MonadServerAtomic m, MonadServerReadRequest m) => Bool -> (FactionId -> m ()) -> FactionId -> Faction -> m Bool {-# INLINE handleFidUpd #-} handleFidUpd True _ _ _ = return True @@ -144,10 +151,11 @@ Nothing -> arenas handle myArenas --- | Handle a clip (a part of a turn for which one or more frames --- will be generated). Run the leader and other actors moves. +-- | Handle a clip (the smallest fraction of a game turn for which a frame may +-- potentially be generated). Run the leader and other actors moves. -- Eventually advance the time and repeat. -loopUpd :: forall m. (MonadAtomic m, MonadServerReadRequest m) => m () -> m () +loopUpd :: forall m. (MonadServerAtomic m, MonadServerReadRequest m) + => m () -> m () loopUpd updConn = do let updatePerFid :: FactionId -> m () {-# NOINLINE updatePerFid #-} @@ -178,16 +186,15 @@ if quit then do modifyServer $ \ser -> ser {squit = False} endOrLoop loopUpdConn (restartGame updConn loopUpdConn) - gameExit (writeSaveAll True) + (writeSaveAll True) else loopUpdConn loopUpdConn -- | Handle the end of every clip. Do whatever has to be done --- every fixed number of time units, e.g., monster generation. +-- every fixed number of clips, e.g., monster generation. -- Advance time. Perform periodic saves, if applicable. -endClip :: forall m. (MonadAtomic m, MonadServer m) - => (FactionId -> m ()) -> m () +endClip :: forall m. MonadServerAtomic m => (FactionId -> m ()) -> m () {-# INLINE endClip #-} endClip updatePerFid = do Kind.COps{corule} <- getsState scops @@ -228,13 +235,12 @@ when (clipN `mod` rwriteSaveClips == 0) $ writeSaveAll False -- | Check if the given actor is dominated and update his calm. -manageCalmAndDomination :: (MonadAtomic m, MonadServer m) - => ActorId -> Actor -> m () +manageCalmAndDomination :: MonadServerAtomic m => ActorId -> Actor -> m () manageCalmAndDomination aid b = do Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops fact <- getsState $ (EM.! bfid b) . sfactionD getItem <- getsState $ flip getItemBody - discoKind <- getsServer sdiscoKind + discoKind <- getsState sdiscoKind let isImpression iid = case EM.lookup (jkindIx $ getItem iid) discoKind of Just KindMean{kmKind} -> maybe False (> 0) (lookup "impressed" $ IK.ifreq $ okind kmKind) @@ -253,15 +259,14 @@ Just fid1 -> assert (fid1 /= bfid b) $ dominateFidSfx fid1 aid else return False unless dominated $ do - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! aid + ar <- getsState $ getActorAspect aid newCalmDelta <- getsState $ regenCalmDelta b ar unless (newCalmDelta == 0) $ -- Update delta for the current player turn. udpateCalm aid newCalmDelta -- | Trigger periodic items for all actors on the given level. -applyPeriodicLevel :: (MonadAtomic m, MonadServer m) => m () +applyPeriodicLevel :: MonadServerAtomic m => m () applyPeriodicLevel = do arenas <- getsServer sarenas let arenasSet = ES.fromDistinctAscList arenas @@ -273,7 +278,7 @@ case iid `EM.lookup` bag of Nothing -> return () -- item dropped Just kit -> do - itemToF <- itemToFullServer + itemToF <- getsState itemToFull let itemFull = itemToF iid kit case itemDisco itemFull of Just ItemDisco {itemKind=IK.ItemKind{IK.ieffects}} -> @@ -292,8 +297,7 @@ allActors <- getsState sactorD mapM_ applyPeriodicActor $ EM.assocs allActors -handleTrajectories :: (MonadAtomic m, MonadServer m) - => LevelId -> FactionId -> m () +handleTrajectories :: MonadServerAtomic m => LevelId -> FactionId -> m () handleTrajectories lid fid = do localTime <- getsState $ getLocalTime lid levelTime <- getsServer $ (EM.! lid) . (EM.! fid) . sactorTime @@ -311,7 +315,7 @@ -- from projectiles or pushed actors doesn't work; too late. -- Even if the actor got teleported to another level by this point, -- we don't care, we set the trajectory, check death, etc. -hTrajectories :: (MonadAtomic m, MonadServer m) => (ActorId, Actor) -> m () +hTrajectories :: MonadServerAtomic m => (ActorId, Actor) -> m () {-# INLINE hTrajectories #-} hTrajectories (aid, b) = do b2 <- if actorDying b then return b else do @@ -344,7 +348,7 @@ -- Not advancing time forces dead projectiles to be destroyed ASAP. -- Otherwise, with some timings, it can stay on the game map dead, -- blocking path of human-controlled actors and alarming the hapless human. -setTrajectory :: (MonadAtomic m, MonadServer m) => ActorId -> m () +setTrajectory :: MonadServerAtomic m => ActorId -> m () {-# INLINE setTrajectory #-} setTrajectory aid = do Kind.COps{coTileSpeedup} <- getsState scops @@ -368,14 +372,14 @@ -- Nothing from non-empty trajectories signifies obstacle hit. execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing -- Lose HP due to flying into an obstacle. - execUpdAtomic $ UpdRefillHP aid minusM + refillHP False aid b minusM Just ([], _) -> -- Non-projectile actor stops flying. assert (not $ bproj b) $ execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing _ -> error $ "Nothing trajectory" `showFailure` (aid, b) -handleActors :: (MonadAtomic m, MonadServerReadRequest m) +handleActors :: (MonadServerAtomic m, MonadServerReadRequest m) => LevelId -> FactionId -> m Bool handleActors lid fid = do localTime <- getsState $ getLocalTime lid @@ -383,14 +387,14 @@ factionD <- getsState sfactionD s <- getState -- Leader acts first, so that UI leader can save&exit before state changes. - let notLeader (aid, b) = Just aid /= _gleader (factionD EM.! bfid b) + let notLeader (aid, b) = Just aid /= gleader (factionD EM.! bfid b) l = sortBy (Ord.comparing notLeader) $ filter (\(_, b) -> isNothing (btrajectory b) && bhp b > 0) $ map (\(a, _) -> (a, getActorBody a s)) $ filter (\(_, atime) -> atime <= localTime) $ EM.assocs levelTime hActors fid l -hActors :: forall m. (MonadAtomic m, MonadServerReadRequest m) +hActors :: forall m. (MonadServerAtomic m, MonadServerReadRequest m) => FactionId -> [(ActorId, Actor)] -> m Bool hActors _ [] = return False hActors _fid as@((aid, body) : rest) = do @@ -398,7 +402,7 @@ !_A = assert (side == _fid) () fact <- getsState $ (EM.! side) . sfactionD squit <- getsServer squit - let mleader = _gleader fact + let mleader = gleader fact aidIsLeader = mleader == Just aid mainUIactor = fhasUI (gplayer fact) && (aidIsLeader @@ -440,74 +444,18 @@ swriteSave <- getsServer swriteSave if swriteSave then return False else hActors side as -gameExit :: (MonadAtomic m, MonadServerReadRequest m) => m () -gameExit = do - -- Verify that the not saved caches are equal to future reconstructed. - -- Otherwise, save/restore would change game state. --- debugPossiblyPrint "Verifying all perceptions." - sperCacheFid <- getsServer sperCacheFid - sperValidFid <- getsServer sperValidFid - sactorAspect <- getsServer sactorAspect - sfovLucidLid <- getsServer sfovLucidLid - sfovClearLid <- getsServer sfovClearLid - sfovLitLid <- getsServer sfovLitLid - sperFid <- getsServer sperFid - discoAspect <- getsServer sdiscoAspect - ( actorAspect, fovLitLid, fovClearLid, fovLucidLid - ,perValidFid, perCacheFid, perFid ) - <- getsState $ perFidInDungeon discoAspect - let !_A7 = assert (sfovLitLid == fovLitLid - `blame` "wrong accumulated sfovLitLid" - `swith` (sfovLitLid, fovLitLid)) () - !_A6 = assert (sfovClearLid == fovClearLid - `blame` "wrong accumulated sfovClearLid" - `swith` (sfovClearLid, fovClearLid)) () - !_A5 = assert (sactorAspect == actorAspect - `blame` "wrong accumulated sactorAspect" - `swith` (sactorAspect, actorAspect)) () - !_A4 = assert (sfovLucidLid == fovLucidLid - `blame` "wrong accumulated sfovLucidLid" - `swith` (sfovLucidLid, fovLucidLid)) () - !_A3 = assert (sperValidFid == perValidFid - `blame` "wrong accumulated sperValidFid" - `swith` (sperValidFid, perValidFid)) () - !_A2 = assert (sperCacheFid == perCacheFid - `blame` "wrong accumulated sperCacheFid" - `swith` (sperCacheFid, perCacheFid)) () - !_A1 = assert (sperFid == perFid - `blame` "wrong accumulated perception" - `swith` (sperFid, perFid)) () - -- 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" --- debugPossiblyPrint "Killing all clients." - killAllClients --- debugPossiblyPrint "All clients killed." - return () - -restartGame :: (MonadAtomic m, MonadServer m) +restartGame :: MonadServerAtomic m => m () -> m () -> Maybe (GroupName ModeKind) -> m () restartGame updConn loop mgameMode = do - cops <- getsState scops - sdebugNxt <- getsServer sdebugNxt + soptionsNxt <- getsServer soptionsNxt srandom <- getsServer srandom - s <- gameReset cops sdebugNxt mgameMode (Just srandom) - let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing} - modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs - , sdebugSer = debugBarRngs } + s <- gameReset soptionsNxt mgameMode (Just srandom) + let optionsBarRngs = soptionsNxt {sdungeonRng = Nothing, smainRng = Nothing} + modifyServer $ \ser -> ser { soptionsNxt = optionsBarRngs + , soptions = optionsBarRngs } execUpdAtomic $ UpdRestartServer s updConn initPer reinitGame writeSaveAll False loop - --- | Save game on server and all clients. -writeSaveAll :: (MonadAtomic m, MonadServer m) => Bool -> m () -writeSaveAll uiRequested = do - bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer - noConfirmsGame <- isNoConfirmsGame - when (uiRequested || not bench && not noConfirmsGame) $ do - execUpdAtomic UpdWriteSave - saveServer diff --git a/Game/LambdaHack/Server/MonadServer.hs b/Game/LambdaHack/Server/MonadServer.hs --- a/Game/LambdaHack/Server/MonadServer.hs +++ b/Game/LambdaHack/Server/MonadServer.hs @@ -1,14 +1,12 @@ --- | Game action monads and basic building blocks for human and computer --- player actions. Has no access to the main action type. --- Does not export the @liftIO@ operation nor a few other implementation --- details. +-- | Basic server monads and related operations. module Game.LambdaHack.Server.MonadServer ( -- * The server monad MonadServer( getsServer , modifyServer - , saveChanServer -- exposed only to be implemented, not used + , chanSaveServer -- exposed only to be implemented, not used , liftIO -- exposed only to be implemented, not used ) + , MonadServerAtomic(..) -- * Assorted primitives , getServer, putServer, debugPossiblyPrint, debugPossiblyPrintAndExit , serverPrint, saveServer, dumpRngs, restoreScore, registerScore @@ -22,41 +20,64 @@ -- Cabal import qualified Paths_LambdaHack as Self (version) -import qualified Control.Exception as Ex hiding (handle) +import qualified Control.Exception as Ex import qualified Control.Monad.Trans.State.Strict as St import qualified Data.EnumMap.Strict as EM import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Time.Clock.POSIX -import Data.Time.LocalTime -import System.Exit (exitFailure) -import System.FilePath -import System.IO (hFlush, stdout) +import Data.Time.Clock.POSIX +import Data.Time.LocalTime +import System.Exit (exitFailure) +import System.FilePath +import System.IO (hFlush, stdout) import qualified System.Random as R -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.ClientOptions -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.File +import Game.LambdaHack.Atomic +import Game.LambdaHack.Client +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.File import qualified Game.LambdaHack.Common.HighScore as HighScore import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Save as Save -import Game.LambdaHack.Common.State -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Server.State +import Game.LambdaHack.Common.State +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.RuleKind +import Game.LambdaHack.Server.ServerOptions +import Game.LambdaHack.Server.State class MonadStateRead m => MonadServer m where getsServer :: (StateServer -> a) -> m a modifyServer :: (StateServer -> StateServer) -> m () - saveChanServer :: m (Save.ChanSave (State, StateServer)) + chanSaveServer :: m (Save.ChanSave (State, StateServer)) -- We do not provide a MonadIO instance, so that outside -- nobody can subvert the action monads by invoking arbitrary IO. liftIO :: IO a -> m a +-- | The monad for executing atomic game state transformations. +class MonadServer m => MonadServerAtomic m where + -- | Execute an atomic command that changes the state + -- on the server and on all clients that can notice it. + execUpdAtomic :: UpdAtomic -> m () + -- | Execute an atomic command that changes the state + -- on the server only. + execUpdAtomicSer :: UpdAtomic -> m Bool + -- | Execute an atomic command that changes the state + -- on the given single client only. + execUpdAtomicFid :: FactionId -> UpdAtomic -> m () + -- | Execute an atomic command that changes the state + -- on the given single client only. + -- Catch 'AtomicFail' and indicate if it was in fact raised. + execUpdAtomicFidCatch :: FactionId -> UpdAtomic -> m Bool + -- | Execute an atomic command that only displays special effects. + execSfxAtomic :: SfxAtomic -> m () + execSendPer :: FactionId -> LevelId + -> Perception -> Perception -> Perception -> m () + getServer :: MonadServer m => m StateServer getServer = getsServer id @@ -65,14 +86,14 @@ debugPossiblyPrint :: MonadServer m => Text -> m () debugPossiblyPrint t = do - debug <- getsServer $ sdbgMsgSer . sdebugSer + debug <- getsServer $ sdbgMsgSer . soptions when debug $ liftIO $ do T.hPutStrLn stdout t hFlush stdout debugPossiblyPrintAndExit :: MonadServer m => Text -> m () debugPossiblyPrintAndExit t = do - debug <- getsServer $ sdbgMsgSer . sdebugSer + debug <- getsServer $ sdbgMsgSer . soptions when debug $ liftIO $ do T.hPutStrLn stdout t hFlush stdout @@ -87,10 +108,10 @@ saveServer = do s <- getState ser <- getServer - toSave <- saveChanServer + toSave <- chanSaveServer liftIO $ Save.saveToChan toSave (s, ser) --- | Dumps RNG states from the start of the game to stdout. +-- | Dumps to stdout the RNG states from the start of the game. dumpRngs :: MonadServer m => RNGs -> m () dumpRngs rngs = liftIO $ do T.hPutStrLn stdout $ tshow rngs @@ -99,7 +120,7 @@ -- | Read the high scores dictionary. Return the empty table if no file. restoreScore :: forall m. MonadServer m => Kind.COps -> m HighScore.ScoreDict restoreScore Kind.COps{corule} = do - bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer + bench <- getsServer $ sbenchmark . sclientOptions . soptions mscore <- if bench then return Nothing else do let stdRuleset = Kind.stdRuleset corule scoresFile = rscoresFile stdRuleset @@ -140,13 +161,15 @@ time <- getsState stime date <- liftIO getPOSIXTime tz <- liftIO $ getTimeZone $ posixSecondsToUTCTime date - curChalSer <- getsServer $ scurChalSer . sdebugSer + curChalSer <- getsServer $ scurChalSer . soptions factionD <- getsState sfactionD - bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer + bench <- getsServer $ sbenchmark . sclientOptions . soptions + noConfirmsGame <- isNoConfirmsGame let path = dataDir scoresFile outputScore (worthMentioning, (ntable, pos)) = - -- If not human, probably debugging, so dump instead of registering. - if bench || isAIFact fact then + -- If testing or fooling around, dump instead of registering. + -- In particular don't register score for the auto-* scenarios. + if bench || noConfirmsGame || isAIFact fact then debugPossiblyPrint $ T.intercalate "\n" $ HighScore.showScore tz (pos, HighScore.getRecord pos ntable) else @@ -179,7 +202,7 @@ modifyServer $ \ser -> ser {srandom = gen1} return $! St.evalState r gen2 --- | Gets a random generator from the arguments or, if not present, +-- | Gets a random generator from the user-submitted options or, if not present, -- generates one. getSetGen :: MonadServer m => Maybe R.StdGen -> m R.StdGen getSetGen mrng = case mrng of diff --git a/Game/LambdaHack/Server/PeriodicM.hs b/Game/LambdaHack/Server/PeriodicM.hs --- a/Game/LambdaHack/Server/PeriodicM.hs +++ b/Game/LambdaHack/Server/PeriodicM.hs @@ -2,8 +2,11 @@ -- and related operations. module Game.LambdaHack.Server.PeriodicM ( spawnMonster, addAnyActor - , advanceTime, overheadActorTime, swapTime - , leadLevelSwitch, udpateCalm + , advanceTime, overheadActorTime, swapTime, udpateCalm, leadLevelSwitch +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , rollSpawnPos +#endif ) where import Prelude () @@ -12,35 +15,35 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Int (Int64) +import Data.Int (Int64) -import Game.LambdaHack.Atomic -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Frequency -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Atomic +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Frequency +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time -import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Server.CommonM -import Game.LambdaHack.Server.ItemM -import Game.LambdaHack.Server.MonadServer -import Game.LambdaHack.Server.State +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Server.CommonM +import Game.LambdaHack.Server.ItemM +import Game.LambdaHack.Server.MonadServer +import Game.LambdaHack.Server.State -- | Spawn, possibly, a monster according to the level's actor groups. -- We assume heroes are never spawned. -spawnMonster :: (MonadAtomic m, MonadServer m) => m () +spawnMonster :: MonadServerAtomic m => m () spawnMonster = do arenas <- getsServer sarenas -- Do this on only one of the arenas to prevent micromanagement, @@ -60,10 +63,10 @@ Nothing -> return () Just aid -> do b <- getsState $ getActorBody aid - mleader <- getsState $ _gleader . (EM.! bfid b) . sfactionD + mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD when (isNothing mleader) $ supplantLeader (bfid b) aid -addAnyActor :: (MonadAtomic m, MonadServer m) +addAnyActor :: MonadServerAtomic m => Freqs ItemKind -> LevelId -> Time -> Maybe Point -> m (Maybe ActorId) addAnyActor actorFreq lid time mpos = do @@ -100,8 +103,7 @@ Nothing -> do rollPos <- getsState $ rollSpawnPos cops allPers mobile lid lvl fid rndToAction rollPos - registerActor itemKnownRaw itemFullRaw itemDisco seed - fid pos lid id time + registerActor itemKnownRaw itemFullRaw seed fid pos lid id time rollSpawnPos :: Kind.COps -> ES.EnumSet Point -> Bool -> LevelId -> Level -> FactionId -> State @@ -149,48 +151,51 @@ ] -- | Advance the move time for the given actor -advanceTime :: (MonadAtomic m, MonadServer m) => ActorId -> Int -> m () +advanceTime :: MonadServerAtomic m => ActorId -> Int -> m () advanceTime aid percent = do b <- getsState $ getActorBody aid - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! aid - t = timeDeltaPercent (ticksPerMeter $ bspeed b ar) percent + ar <- getsState $ getActorAspect aid + let t = timeDeltaPercent (ticksPerMeter $ bspeed b ar) percent -- @t@ may be negative; that's OK. modifyServer $ \ser -> ser {sactorTime = ageActor (bfid b) (blid b) aid t $ sactorTime ser} -- Add communication overhead time delta to all non-projectile, non-dying --- faction's actors (except the leader). Effectively, this limits moves of --- a faction to 10, regardless of the number of actors and their speeds. --- To discourage micromanagement distributing actors among active arenas, --- overhead applies to all actors in active arenas. +-- faction's actors (except the leader). Effectively, this limits moves +-- of a faction on a level to 10, regardless of the number of actors +-- and their speeds. To avoid animals suddenly acting extremely sluggish +-- whenever monster's leader visits a distant arena that has a crowd +-- of animals, overhead applies only to actors on the same level. +-- Since the number of active arenas is limited, this bounds the total moves +-- per turn of each faction as well. -- -- Leader is immune from overhead and so he is faster than other faction -- members and of equal speed to leaders of other factions (of equal -- base speed) regardless how numerous the faction is. -- Thanks to this, there is no problem with leader of a numerous faction -- having very long UI turns, introducing UI lag. -overheadActorTime :: (MonadAtomic m, MonadServer m) => FactionId -> m () -overheadActorTime fid = do +overheadActorTime :: MonadServerAtomic m => FactionId -> LevelId -> m () +overheadActorTime fid lid = do actorTime <- getsServer $ (EM.! fid) . sactorTime s <- getState - mleader <- getsState $ _gleader . (EM.! fid) . sfactionD + mleader <- getsState $ gleader . (EM.! fid) . sfactionD arenas <- getsServer sarenas - let f !aid !time = + let f !lid2 !_aid !time | lid2 /= lid = time + f _ aid time = let body = getActorBody aid s in if isNothing (btrajectory body) && bhp body > 0 && Just aid /= mleader -- leader fast, for UI to be fast then timeShift time (Delta timeClip) else time - g !acc !lid = EM.adjust (EM.mapWithKey f) lid acc + g !acc !lid2 = EM.adjust (EM.mapWithKey $ f lid2) lid acc actorTimeNew = foldl' g actorTime arenas modifyServer $ \ser -> ser {sactorTime = EM.insert fid actorTimeNew $ sactorTime ser} -- | Swap the relative move times of two actors (e.g., when switching -- a UI leader). -swapTime :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m () +swapTime :: MonadServerAtomic m => ActorId -> ActorId -> m () swapTime source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target @@ -217,12 +222,11 @@ when (tdelta /= Delta timeZero) $ modifyServer $ \ser -> ser {sactorTime = ageActor (bfid tb) (blid tb) target tdelta $ sactorTime ser} -udpateCalm :: (MonadAtomic m, MonadServer m) => ActorId -> Int64 -> m () +udpateCalm :: MonadServerAtomic m => ActorId -> Int64 -> m () udpateCalm target deltaCalm = do tb <- getsState $ getActorBody target - actorAspect <- getsServer sactorAspect - let ar = actorAspect EM.! target - calmMax64 = xM $ aMaxCalm ar + ar <- getsState $ getActorAspect target + let calmMax64 = xM $ aMaxCalm ar execUpdAtomic $ UpdRefillCalm target deltaCalm when (bcalm tb < calmMax64 && bcalm tb + deltaCalm >= calmMax64) $ @@ -232,7 +236,7 @@ -- to regenerate Calm. This is unnatural and boring. Better fight -- and hope he gets his Calm again to 0 and then defects back. -leadLevelSwitch :: (MonadAtomic m, MonadServer m) => m () +leadLevelSwitch :: MonadServerAtomic m => m () leadLevelSwitch = do let canSwitch fact = fst (autoDungeonLevel fact) -- a hack to help AI, until AI client can switch levels @@ -242,7 +246,7 @@ LeaderUI _ -> False flipFaction fact | not $ canSwitch fact = return () flipFaction fact = - case _gleader fact of + case gleader fact of Nothing -> return () Just leader -> do body <- getsState $ getActorBody leader diff --git a/Game/LambdaHack/Server/ProtocolM.hs b/Game/LambdaHack/Server/ProtocolM.hs --- a/Game/LambdaHack/Server/ProtocolM.hs +++ b/Game/LambdaHack/Server/ProtocolM.hs @@ -1,7 +1,7 @@ -- | The server definitions for the server-client communication protocol. module Game.LambdaHack.Server.ProtocolM ( -- * The communication channels - ConnServerDict + CliSerQueue, ConnServerDict, ChanServer(..) -- * The server-client communication monad , MonadServerReadRequest ( getsDict -- exposed only to be implemented, not used @@ -9,11 +9,13 @@ , liftIO -- exposed only to be implemented, not used ) -- * Protocol - , putDict, sendUpdate, sendSfx, sendQueryAI, sendQueryUI + , putDict, sendUpdate, sendUpdateCheck, sendUpdNoState + , sendSfx, sendQueryAI, sendQueryUI -- * Assorted , killAllClients, childrenServer, updateConn, tryRestore #ifdef EXPOSE_INTERNAL -- * Internal operations + , writeQueue, readQueueAI, readQueueUI, newQueue #endif ) where @@ -21,32 +23,30 @@ import Game.LambdaHack.Common.Prelude -import Control.Concurrent -import Control.Concurrent.Async +import Control.Concurrent +import Control.Concurrent.Async import qualified Data.EnumMap.Strict as EM -import Data.Key (mapWithKeyM, mapWithKeyM_) -import System.FilePath -import System.IO.Unsafe (unsafePerformIO) +import Data.Key (mapWithKeyM, mapWithKeyM_) +import System.FilePath +import System.IO.Unsafe (unsafePerformIO) -import Game.LambdaHack.Atomic -import Game.LambdaHack.Client (Config, SessionUI, emptySessionUI) -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ClientOptions -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.File +import Game.LambdaHack.Atomic +import Game.LambdaHack.Client +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.File import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.Response +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead import qualified Game.LambdaHack.Common.Save as Save -import Game.LambdaHack.Common.State -import Game.LambdaHack.Common.Thread -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Server.DebugM -import Game.LambdaHack.Server.MonadServer hiding (liftIO) -import Game.LambdaHack.Server.State +import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Thread +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.RuleKind +import Game.LambdaHack.Server.DebugM +import Game.LambdaHack.Server.MonadServer hiding (liftIO) +import Game.LambdaHack.Server.ServerOptions +import Game.LambdaHack.Server.State writeQueue :: MonadServerReadRequest m => Response -> CliSerQueue Response -> m () @@ -54,40 +54,30 @@ writeQueue cmd responseS = liftIO $ putMVar responseS cmd readQueueAI :: MonadServerReadRequest m - => CliSerQueue RequestAI - -> m RequestAI + => CliSerQueue RequestAI -> m RequestAI {-# INLINE readQueueAI #-} readQueueAI requestS = liftIO $ takeMVar requestS readQueueUI :: MonadServerReadRequest m - => CliSerQueue RequestUI - -> m RequestUI + => CliSerQueue RequestUI -> m RequestUI {-# INLINE readQueueUI #-} readQueueUI requestS = liftIO $ takeMVar requestS newQueue :: IO (CliSerQueue a) newQueue = newEmptyMVar -tryRestore :: MonadServerReadRequest m - => Kind.COps -> DebugModeSer - -> m (Maybe (State, StateServer)) -tryRestore cops@Kind.COps{corule} sdebugSer = do - let bench = sbenchmark $ sdebugCli sdebugSer - if bench then return Nothing - else do - let prefix = ssavePrefixSer sdebugSer - fileName = prefix <> Save.saveNameSer cops - res <- liftIO $ Save.restoreGame cops fileName - let stdRuleset = Kind.stdRuleset corule - cfgUIName = rcfgUIName stdRuleset - content = rcfgUIDefault stdRuleset - dataDir <- liftIO appDataDir - liftIO $ tryWriteFile (dataDir cfgUIName) content - return $! res +type CliSerQueue = MVar -- | Connection information for all factions, indexed by faction identifier. type ConnServerDict = EM.EnumMap FactionId ChanServer +-- | Connection channel between the server and a single client. +data ChanServer = ChanServer + { responseS :: CliSerQueue Response + , requestAIS :: CliSerQueue RequestAI + , requestUIS :: Maybe (CliSerQueue RequestUI) + } + -- | The server monad with the ability to communicate with clients. class MonadServer m => MonadServerReadRequest m where getsDict :: (ConnServerDict -> a) -> m a @@ -100,18 +90,43 @@ putDict :: MonadServerReadRequest m => ConnServerDict -> m () putDict s = modifyDict (const s) -sendUpdate :: MonadServerReadRequest m => FactionId -> UpdAtomic -> m () +-- | If the @AtomicFail@ conditions hold, send a command to client, +-- otherwise do nothing. +sendUpdate :: (MonadServerAtomic m, MonadServerReadRequest m) + => FactionId -> UpdAtomic -> m () sendUpdate !fid !cmd = do + succeeded <- execUpdAtomicFidCatch fid cmd + when succeeded $ sendUpd fid cmd + +-- | Send a command to client, crashing if the @AtomicFail@ conditions +-- don't hold when executed on the client's state. +sendUpdateCheck :: (MonadServerAtomic m, MonadServerReadRequest m) + => FactionId -> UpdAtomic -> m () +sendUpdateCheck !fid !cmd = do + execUpdAtomicFid fid cmd + sendUpd fid cmd + +sendUpd :: MonadServerReadRequest m => FactionId -> UpdAtomic -> m () +sendUpd !fid !cmd = do chan <- getsDict (EM.! fid) - let resp = RespUpdAtomic cmd - debug <- getsServer $ sniffOut . sdebugSer + s <- getsServer $ (EM.! fid) . sclientStates + let resp = RespUpdAtomic s cmd + debug <- getsServer $ sniff . soptions when debug $ debugResponse fid resp writeQueue resp $ responseS chan +sendUpdNoState :: MonadServerReadRequest m => FactionId -> UpdAtomic -> m () +sendUpdNoState !fid !cmd = do + chan <- getsDict (EM.! fid) + let resp = RespUpdAtomicNoState cmd + debug <- getsServer $ sniff . soptions + when debug $ debugResponse fid resp + writeQueue resp $ responseS chan + sendSfx :: MonadServerReadRequest m => FactionId -> SfxAtomic -> m () sendSfx !fid !sfx = do let resp = RespSfxAtomic sfx - debug <- getsServer $ sniffOut . sdebugSer + debug <- getsServer $ sniff . soptions when debug $ debugResponse fid resp chan <- getsDict (EM.! fid) case chan of @@ -121,34 +136,34 @@ sendQueryAI :: MonadServerReadRequest m => FactionId -> ActorId -> m RequestAI sendQueryAI fid aid = do let respAI = RespQueryAI aid - debug <- getsServer $ sniffOut . sdebugSer + debug <- getsServer $ sniff . soptions when debug $ debugResponse fid respAI chan <- getsDict (EM.! fid) req <- do writeQueue respAI $ responseS chan readQueueAI $ requestAIS chan - when debug $ debugRequestAI aid req + when debug $ debugRequestAI aid return req -sendQueryUI :: (MonadAtomic m, MonadServerReadRequest m) +sendQueryUI :: (MonadServerAtomic m, MonadServerReadRequest m) => FactionId -> ActorId -> m RequestUI sendQueryUI fid _aid = do let respUI = RespQueryUI - debug <- getsServer $ sniffOut . sdebugSer + debug <- getsServer $ sniff . soptions when debug $ debugResponse fid respUI chan <- getsDict (EM.! fid) req <- do writeQueue respUI $ responseS chan readQueueUI $ fromJust $ requestUIS chan - when debug $ debugRequestUI _aid req + when debug $ debugRequestUI _aid return req -killAllClients :: (MonadAtomic m, MonadServerReadRequest m) => m () +killAllClients :: (MonadServerAtomic m, MonadServerReadRequest m) => m () killAllClients = do d <- getDict - let sendKill fid _ = - -- We can't check in sfactionD, because client can be from an old game. - sendUpdate fid $ UpdKillExit fid + let sendKill fid _ = sendUpdNoState fid $ UpdKillExit fid + -- We can't interate over sfactionD, because client can be from an old game. + -- For the same reason we can't look up and send client's state. mapWithKeyM_ sendKill d -- Global variable for all children threads of the server. @@ -159,15 +174,13 @@ -- | Update connections to the new definition of factions. -- Connect to clients in old or newly spawned threads -- that read and write directly to the channels. -updateConn :: (MonadAtomic m, MonadServerReadRequest m) - => Config - -> (Maybe SessionUI -> FactionId -> ChanServer -> IO ()) +updateConn :: (MonadServerAtomic m, MonadServerReadRequest m) + => (Bool -> FactionId -> ChanServer -> IO ()) -> m () -updateConn sconfig executorClient = do +updateConn executorClient = do -- Prepare connections based on factions. oldD <- getDict - let sess = emptySessionUI sconfig - mkChanServer :: Faction -> IO ChanServer + let mkChanServer :: Faction -> IO ChanServer mkChanServer fact = do responseS <- newQueue requestAIS <- newQueue @@ -186,9 +199,9 @@ -- Spawn client threads. let toSpawn = newD EM.\\ oldD forkUI fid connS = - forkChild childrenServer $ executorClient (Just sess) fid connS + forkChild childrenServer $ executorClient True fid connS forkAI fid connS = - forkChild childrenServer $ executorClient Nothing fid connS + forkChild childrenServer $ executorClient False fid connS forkClient fid conn@ChanServer{requestUIS=Nothing} = -- When a connection is reused, clients are not respawned, -- even if UI usage changes, but it works OK thanks to UI faction @@ -197,3 +210,20 @@ forkClient fid conn = forkUI fid conn liftIO $ mapWithKeyM_ forkClient toSpawn + +tryRestore :: MonadServerReadRequest m => m (Maybe (State, StateServer)) +tryRestore = do + cops@Kind.COps{corule} <- getsState scops + soptions <- getsServer soptions + let bench = sbenchmark $ sclientOptions soptions + if bench then return Nothing + else do + let prefix = ssavePrefixSer soptions + fileName = prefix <> Save.saveNameSer cops + res <- liftIO $ Save.restoreGame cops fileName + let stdRuleset = Kind.stdRuleset corule + cfgUIName = rcfgUIName stdRuleset + content = rcfgUIDefault stdRuleset + dataDir <- liftIO appDataDir + liftIO $ tryWriteFile (dataDir cfgUIName) content + return $! res diff --git a/Game/LambdaHack/Server/ServerOptions.hs b/Game/LambdaHack/Server/ServerOptions.hs new file mode 100644 --- /dev/null +++ b/Game/LambdaHack/Server/ServerOptions.hs @@ -0,0 +1,126 @@ +-- | Server and client game state types and operations. +module Game.LambdaHack.Server.ServerOptions + ( ServerOptions(..), RNGs(..), defServerOptions + ) where + +import Prelude () + +import Game.LambdaHack.Common.Prelude + +import Data.Binary +import qualified System.Random as R + +import Game.LambdaHack.Client +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Content.ModeKind + +-- | Options that affect the behaviour of the server (including game rules). +data ServerOptions = ServerOptions + { sknowMap :: Bool + , sknowEvents :: Bool + , sknowItems :: Bool + , sniff :: Bool + , sallClear :: Bool + , sboostRandomItem :: Bool + , sgameMode :: Maybe (GroupName ModeKind) + , sautomateAll :: Bool + , skeepAutomated :: Bool + , sdungeonRng :: Maybe R.StdGen + , smainRng :: Maybe R.StdGen + , snewGameSer :: Bool + , scurChalSer :: Challenge + , sdumpInitRngs :: Bool + , ssavePrefixSer :: String + , sdbgMsgSer :: Bool + , sclientOptions :: ClientOptions + -- The client debug inside server debug only holds the client commandline + -- options and is never updated with config options, etc. + } + deriving Show + +data RNGs = RNGs + { dungeonRandomGenerator :: Maybe R.StdGen + , startingRandomGenerator :: Maybe R.StdGen + } + +instance Show RNGs where + show RNGs{..} = + let args = [ maybe "" (\gen -> "--setDungeonRng \"" ++ show gen ++ "\"") + dungeonRandomGenerator + , maybe "" (\gen -> "--setMainRng \"" ++ show gen ++ "\"") + startingRandomGenerator ] + in unwords args + +instance Binary ServerOptions where + put ServerOptions{..} = do + put sknowMap + put sknowEvents + put sknowItems + put sniff + put sallClear + put sboostRandomItem + put sgameMode + put sautomateAll + put skeepAutomated + put scurChalSer + put ssavePrefixSer + put sdbgMsgSer + put sclientOptions + get = do + sknowMap <- get + sknowEvents <- get + sknowItems <- get + sniff <- get + sallClear <- get + sboostRandomItem <- get + sgameMode <- get + sautomateAll <- get + skeepAutomated <- get + scurChalSer <- get + ssavePrefixSer <- get + sdbgMsgSer <- get + sclientOptions <- get + let sdungeonRng = Nothing + smainRng = Nothing + snewGameSer = False + sdumpInitRngs = False + return $! ServerOptions{..} + +instance Binary RNGs where + put RNGs{..} = do + put (show dungeonRandomGenerator) + put (show startingRandomGenerator) + get = do + dg <- get + sg <- get + let dungeonRandomGenerator = read dg + startingRandomGenerator = read sg + return $! RNGs{..} + +-- | Default value of server options. +defServerOptions :: ServerOptions +defServerOptions = ServerOptions + { sknowMap = False + , sknowEvents = False + , sknowItems = False + , sniff = False + , sallClear = False + , sboostRandomItem = False + , sgameMode = Nothing + , sautomateAll = False + , skeepAutomated = False + , sdungeonRng = Nothing + , smainRng = Nothing + , snewGameSer = False + , scurChalSer = defaultChallenge +-- for debug; hard to set manually in browser: +#ifdef USE_BROWSER + , sdumpInitRngs = True +#else + , sdumpInitRngs = False +#endif + , ssavePrefixSer = "" + , sdbgMsgSer = False + , sclientOptions = defClientOptions + } diff --git a/Game/LambdaHack/Server/StartM.hs b/Game/LambdaHack/Server/StartM.hs --- a/Game/LambdaHack/Server/StartM.hs +++ b/Game/LambdaHack/Server/StartM.hs @@ -1,81 +1,84 @@ -- | Operations for starting and restarting the game. module Game.LambdaHack.Server.StartM - ( gameReset, reinitGame, updatePer, initPer, applyDebug + ( initPer, reinitGame, gameReset, applyDebug +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , mapFromFuns, resetFactions, populateDungeon, findEntryPoss +#endif ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Control.Arrow (first) import qualified Control.Monad.Trans.State.Strict as St import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.IntMap.Strict as IM -import Data.Key (mapWithKeyM_) +import Data.Key (mapWithKeyM_) import qualified Data.Map.Strict as M -import Data.Ord +import Data.Ord import qualified Data.Text as T -import Data.Tuple (swap) +import Data.Tuple (swap) import qualified NLP.Miniutter.English as MU import qualified System.Random as R -import Game.LambdaHack.Atomic -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.ClientOptions +import Game.LambdaHack.Atomic +import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Flavour -import qualified Game.LambdaHack.Common.HighScore as HighScore -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Flavour +import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.Point -import Game.LambdaHack.Common.Random -import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Random +import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Time import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Server.CommonM +import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Server.CommonM import qualified Game.LambdaHack.Server.DungeonGen as DungeonGen -import Game.LambdaHack.Server.Fov -import Game.LambdaHack.Server.ItemM -import Game.LambdaHack.Server.ItemRev -import Game.LambdaHack.Server.MonadServer -import Game.LambdaHack.Server.State +import Game.LambdaHack.Server.Fov +import Game.LambdaHack.Server.ItemM +import Game.LambdaHack.Server.ItemRev +import Game.LambdaHack.Server.MonadServer +import Game.LambdaHack.Server.ServerOptions +import Game.LambdaHack.Server.State initPer :: MonadServer m => m () initPer = do - discoAspect <- getsServer sdiscoAspect - ( sactorAspect, sfovLitLid, sfovClearLid, sfovLucidLid - ,sperValidFid, sperCacheFid, sperFid ) - <- getsState $ perFidInDungeon discoAspect + ( sfovLitLid, sfovClearLid, sfovLucidLid + ,sperValidFid, sperCacheFid, sperFid ) <- getsState perFidInDungeon modifyServer $ \ser -> - ser { sactorAspect, sfovLitLid, sfovClearLid, sfovLucidLid + ser { sfovLitLid, sfovClearLid, sfovLucidLid , sperValidFid, sperCacheFid, sperFid } -reinitGame :: (MonadAtomic m, MonadServer m) => m () +reinitGame :: MonadServerAtomic m => m () reinitGame = do Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops pers <- getsServer sperFid - DebugModeSer{scurChalSer, sknowMap, sdebugCli} <- getsServer sdebugSer + ServerOptions{scurChalSer, sknowMap, sclientOptions} <- getsServer soptions -- This state is quite small, fit for transmition to the client. -- The biggest part is content, which needs to be updated -- at this point to keep clients in sync with server improvements. s <- getState - let defLocal | sknowMap = s - | otherwise = localFromGlobal s - discoS <- getsServer sdiscoKind - let sdiscoKind = + discoS <- getsState sdiscoKind + -- Thanks to the following, for any item with feature @Identified@, + -- the client has its kind from the start. + let discoKindFiltered = let f KindMean{kmKind} = IK.Identified `elem` IK.ifeature (okind kmKind) in EM.filter f discoS - updRestart fid = UpdRestart fid sdiscoKind (pers EM.! fid) defLocal - scurChalSer sdebugCli + defL | sknowMap = s + | otherwise = localFromGlobal s + defLocal = updateDiscoKind (const discoKindFiltered) defL factionD <- getsState sfactionD + modifyServer $ \ser -> ser {sclientStates = EM.map (const defLocal) factionD} + let updRestart fid = UpdRestart fid (pers EM.! fid) defLocal + scurChalSer sclientOptions mapWithKeyM_ (\fid _ -> execUpdAtomic $ updRestart fid) factionD dungeon <- getsState sdungeon let sactorTime = EM.map (const (EM.map (const EM.empty) dungeon)) factionD @@ -83,23 +86,7 @@ populateDungeon mapM_ (\fid -> mapM_ (updatePer fid) (EM.keys dungeon)) (EM.keys factionD) - execUpdAtomic $ UpdMsgAll "SortSlots" -- hack - -updatePer :: (MonadAtomic m, MonadServer m) => FactionId -> LevelId -> m () -{-# INLINE updatePer #-} -updatePer fid lid = do - modifyServer $ \ser -> - ser {sperValidFid = EM.adjust (EM.insert lid True) fid $ sperValidFid ser} - sperFidOld <- getsServer sperFid - let perOld = sperFidOld EM.! fid EM.! lid - knowEvents <- getsServer $ sknowEvents . sdebugSer - -- Performed in the State after action, e.g., with a new actor. - perNew <- recomputeCachePer fid lid - let inPer = diffPer perNew perOld - outPer = diffPer perOld perNew - unless (nullPer outPer && nullPer inPer) $ - unless knowEvents $ -- inconsistencies would quickly manifest - execSendPer fid lid outPer inPer perNew + execSfxAtomic SfxSortSlots mapFromFuns :: (Bounded a, Enum a, Ord b) => [a -> b] -> M.Map b a mapFromFuns = @@ -173,30 +160,27 @@ return $! warFs gameReset :: MonadServer m - => Kind.COps -> DebugModeSer -> Maybe (GroupName ModeKind) + => ServerOptions -> Maybe (GroupName ModeKind) -> Maybe R.StdGen -> m State -gameReset cops@Kind.COps{comode=Kind.Ops{opick, okind}} - sdebug mGameMode mrandom = do +gameReset serverOptions mGameMode mrandom = do -- Dungeon seed generation has to come first, to ensure item boosting -- is determined by the dungeon RNG. - dungeonSeed <- getSetGen $ sdungeonRng sdebug `mplus` mrandom - srandom <- getSetGen $ smainRng sdebug `mplus` mrandom + cops@Kind.COps{comode=Kind.Ops{opick, okind}} <- getsState scops + dungeonSeed <- getSetGen $ sdungeonRng serverOptions `mplus` mrandom + srandom <- getSetGen $ smainRng serverOptions `mplus` mrandom let srngs = RNGs (Just dungeonSeed) (Just srandom) - when (sdumpInitRngs sdebug) $ dumpRngs srngs - scoreTable <- if sfrontendNull $ sdebugCli sdebug then - return HighScore.empty - else - restoreScore cops + when (sdumpInitRngs serverOptions) $ dumpRngs srngs + scoreTable <- restoreScore cops factionDold <- getsState sfactionD gameModeIdOld <- getsState sgameModeId - curChalSer <- getsServer $ scurChalSer . sdebugSer + curChalSer <- getsServer $ scurChalSer . soptions #ifdef USE_BROWSER let startingModeGroup = "starting JS" #else let startingModeGroup = "starting" #endif gameMode = fromMaybe startingModeGroup - $ mGameMode `mplus` sgameMode sdebug + $ mGameMode `mplus` sgameMode serverOptions rnd :: Rnd (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev, DungeonGen.FreshDungeon, Kind.Id ModeKind) rnd = do @@ -205,38 +189,38 @@ let mode = okind modeKindId automatePS ps = ps {rosterList = map (first $ automatePlayer True) $ rosterList ps} - players = if sautomateAll sdebug + players = if sautomateAll serverOptions then automatePS $ mroster mode else mroster mode sflavour <- dungeonFlavourMap cops - (sdiscoKind, sdiscoKindRev) <- serverDiscos cops + (discoKind, sdiscoKindRev) <- serverDiscos cops freshDng <- DungeonGen.dungeonGen cops $ mcaves mode factionD <- resetFactions factionDold gameModeIdOld (cdiff curChalSer) (DungeonGen.freshTotalDepth freshDng) players - return ( factionD, sflavour, sdiscoKind + return ( factionD, sflavour, discoKind , sdiscoKindRev, freshDng, modeKindId ) - let ( factionD, sflavour, sdiscoKind + let ( factionD, sflavour, discoKind ,sdiscoKindRev, DungeonGen.FreshDungeon{..}, modeKindId ) = St.evalState rnd dungeonSeed defState = defStateGlobal freshDungeon freshTotalDepth - factionD cops scoreTable modeKindId + factionD cops scoreTable modeKindId discoKind defSer = emptyStateServer { srandom , srngs } putServer defSer - modifyServer $ \ser -> ser {sdiscoKind, sdiscoKindRev, sflavour} + modifyServer $ \ser -> ser {sdiscoKindRev, sflavour} return $! defState -- Spawn initial actors. Clients should notice this, to set their leaders. -populateDungeon :: (MonadAtomic m, MonadServer m) => m () +populateDungeon :: MonadServerAtomic m => m () populateDungeon = do cops@Kind.COps{coTileSpeedup} <- getsState scops placeItemsInDungeon embedItemsInDungeon dungeon <- getsState sdungeon factionD <- getsState sfactionD - curChalSer <- getsServer $ scurChalSer . sdebugSer + curChalSer <- getsServer $ scurChalSer . soptions let ginitialWolf fact1 = if cwolf curChalSer && fhasUI (gplayer fact1) then case ginitial fact1 of [] -> [] @@ -293,7 +277,7 @@ Nothing -> error $ "can't spawn initial actors" `showFailure` (lid, (fid3, fact3)) Just aid -> do - mleader <- getsState $ _gleader . (EM.! fid3) . sfactionD + mleader <- getsState $ gleader . (EM.! fid3) . sfactionD when (isNothing mleader) $ supplantLeader fid3 aid return True mapM_ initialActors arenas @@ -335,15 +319,14 @@ found <- tryFind (middlePos : onStairs) nk return $! found ++ onStairs --- | Apply debug options that don't need a new game. +-- | Apply options that don't need a new game. applyDebug :: MonadServer m => m () applyDebug = do - DebugModeSer{..} <- getsServer sdebugNxt + ServerOptions{..} <- getsServer soptionsNxt modifyServer $ \ser -> - ser {sdebugSer = (sdebugSer ser) { sniffIn - , sniffOut - , sallClear - , sdbgMsgSer - , snewGameSer - , sdumpInitRngs - , sdebugCli }} + ser {soptions = (soptions ser) { sniff + , sallClear + , sdbgMsgSer + , snewGameSer + , sdumpInitRngs + , sclientOptions }} diff --git a/Game/LambdaHack/Server/State.hs b/Game/LambdaHack/Server/State.hs --- a/Game/LambdaHack/Server/State.hs +++ b/Game/LambdaHack/Server/State.hs @@ -1,16 +1,14 @@ -- | Server and client game state types and operations. module Game.LambdaHack.Server.State - ( StateServer(..), emptyStateServer - , DebugModeSer(..), defDebugModeSer - , RNGs(..) - , ActorTime, updateActorTime, ageActor + ( StateServer(..), ActorTime + , emptyStateServer, updateActorTime, ageActor ) where import Prelude () import Game.LambdaHack.Common.Prelude -import Data.Binary +import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.HashMap.Strict as HM @@ -18,109 +16,60 @@ import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Level -import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time -import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.ItemRev +import Game.LambdaHack.Server.ServerOptions --- | Global, server state. +-- | State with server-specific data, including a copy of each client's +-- basic game state, but not the server's basic state. data StateServer = StateServer - { sactorTime :: ActorTime -- ^ absolute times of next actions - , sdiscoKind :: DiscoveryKind -- ^ full item kind discoveries data - , sdiscoKindRev :: DiscoveryKindRev -- ^ reverse map, used for item creation - , suniqueSet :: UniqueSet -- ^ already generated unique items - , sdiscoAspect :: DiscoveryAspect -- ^ full item aspect data - , sitemSeedD :: ItemSeedDict -- ^ map from item ids to item seeds - , sitemRev :: ItemRev -- ^ reverse id map, used for item creation - , sflavour :: FlavourMap -- ^ association of flavour to items - , sacounter :: ActorId -- ^ stores next actor index - , sicounter :: ItemId -- ^ stores next item index + { sactorTime :: ActorTime -- ^ absolute times of next actions + , sdiscoKindRev :: DiscoveryKindRev + -- ^ reverse map, used for item creation + , suniqueSet :: UniqueSet -- ^ already generated unique items + , sitemSeedD :: ItemSeedDict -- ^ map from item ids to item seeds + , sitemRev :: ItemRev -- ^ reverse id map, used for item creation + , sflavour :: FlavourMap -- ^ association of flavour to items + , sacounter :: ActorId -- ^ stores next actor index + , sicounter :: ItemId -- ^ stores next item index , snumSpawned :: EM.EnumMap LevelId Int - , sundo :: [CmdAtomic] -- ^ atomic commands performed to date - , sperFid :: PerFid -- ^ perception of all factions - , sperValidFid :: PerValidFid -- ^ perception validity for all factions - , sperCacheFid :: PerCacheFid -- ^ perception cache of all factions - , sactorAspect :: ActorAspect -- ^ full actor aspect data - , sfovLucidLid :: FovLucidLid -- ^ ambient or shining light positions - , sfovClearLid :: FovClearLid -- ^ clear tiles positions - , sfovLitLid :: FovLitLid -- ^ ambient light positions - , sarenas :: [LevelId] -- ^ active arenas - , svalidArenas :: Bool -- ^ whether active arenas valid - , srandom :: R.StdGen -- ^ current random generator - , srngs :: RNGs -- ^ initial random generators - , squit :: Bool -- ^ exit the game loop - , swriteSave :: Bool -- ^ write savegame to a file now - , sdebugSer :: DebugModeSer -- ^ current debugging mode - , sdebugNxt :: DebugModeSer -- ^ debugging mode for the next game + , sundo :: [CmdAtomic] -- ^ atomic commands performed to date + , sclientStates :: EM.EnumMap FactionId State + -- ^ each faction state, as seen by clients + , sperFid :: PerFid -- ^ perception of all factions + , sperValidFid :: PerValidFid -- ^ perception validity for all factions + , sperCacheFid :: PerCacheFid -- ^ perception cache of all factions + , sfovLucidLid :: FovLucidLid -- ^ ambient or shining light positions + , sfovClearLid :: FovClearLid -- ^ clear tiles positions + , sfovLitLid :: FovLitLid -- ^ ambient light positions + , sarenas :: [LevelId] -- ^ active arenas + , svalidArenas :: Bool -- ^ whether active arenas valid + , srandom :: R.StdGen -- ^ current random generator + , srngs :: RNGs -- ^ initial random generators + , squit :: Bool -- ^ exit the game loop + , swriteSave :: Bool -- ^ write savegame to a file now + , soptions :: ServerOptions -- ^ current commandline options + , soptionsNxt :: ServerOptions -- ^ options for the next game } deriving (Show) --- | Debug commands. See 'Server.debugArgs' for the descriptions. -data DebugModeSer = DebugModeSer - { sknowMap :: Bool - , sknowEvents :: Bool - , sknowItems :: Bool - , sniffIn :: Bool - , sniffOut :: Bool - , sallClear :: Bool - , sboostRandomItem :: Bool - , sgameMode :: Maybe (GroupName ModeKind) - , sautomateAll :: Bool - , skeepAutomated :: Bool - , sdungeonRng :: Maybe R.StdGen - , smainRng :: Maybe R.StdGen - , snewGameSer :: Bool - , scurChalSer :: Challenge - , sdumpInitRngs :: Bool - , ssavePrefixSer :: String - , sdbgMsgSer :: Bool - , sdebugCli :: DebugModeCli - -- The client debug inside server debug only holds the client commandline - -- options and is never updated with config options, etc. - } - deriving Show - -data RNGs = RNGs - { dungeonRandomGenerator :: Maybe R.StdGen - , startingRandomGenerator :: Maybe R.StdGen - } - -instance Show RNGs where - show RNGs{..} = - let args = [ maybe "" (\gen -> "--setDungeonRng \"" ++ show gen ++ "\"") - dungeonRandomGenerator - , maybe "" (\gen -> "--setMainRng \"" ++ show gen ++ "\"") - startingRandomGenerator ] - in unwords args - +-- | Position in time for each actor, grouped by level and by faction. type ActorTime = EM.EnumMap FactionId (EM.EnumMap LevelId (EM.EnumMap ActorId Time)) -updateActorTime :: FactionId -> LevelId -> ActorId -> Time -> ActorTime - -> ActorTime -updateActorTime !fid !lid !aid !time = - EM.adjust (EM.adjust (EM.insert aid time) lid) fid - -ageActor :: FactionId -> LevelId -> ActorId -> Delta Time -> ActorTime - -> ActorTime -ageActor !fid !lid !aid !delta = - EM.adjust (EM.adjust (EM.adjust (`timeShift` delta) aid) lid) fid - -- | Initial, empty game server state. emptyStateServer :: StateServer emptyStateServer = StateServer { sactorTime = EM.empty - , sdiscoKind = EM.empty , sdiscoKindRev = EM.empty , suniqueSet = ES.empty - , sdiscoAspect = EM.empty , sitemSeedD = EM.empty , sitemRev = HM.empty , sflavour = emptyFlavourMap @@ -128,10 +77,10 @@ , sicounter = toEnum 0 , snumSpawned = EM.empty , sundo = [] + , sclientStates = EM.empty , sperFid = EM.empty , sperValidFid = EM.empty , sperCacheFid = EM.empty - , sactorAspect = EM.empty , sfovLucidLid = EM.empty , sfovClearLid = EM.empty , sfovLitLid = EM.empty @@ -142,74 +91,54 @@ , startingRandomGenerator = Nothing } , squit = False , swriteSave = False - , sdebugSer = defDebugModeSer - , sdebugNxt = defDebugModeSer + , soptions = defServerOptions + , soptionsNxt = defServerOptions } -defDebugModeSer :: DebugModeSer -defDebugModeSer = DebugModeSer { sknowMap = False - , sknowEvents = False - , sknowItems = False - , sniffIn = False - , sniffOut = False - , sallClear = False - , sboostRandomItem = False - , sgameMode = Nothing - , sautomateAll = False - , skeepAutomated = False - , sdungeonRng = Nothing - , smainRng = Nothing - , snewGameSer = False - , scurChalSer = defaultChallenge --- for debug; hard to set manually in browser: -#ifdef USE_BROWSER - , sdumpInitRngs = True -#else - , sdumpInitRngs = False -#endif - , ssavePrefixSer = "" - , sdbgMsgSer = False - , sdebugCli = defDebugModeCli - } +updateActorTime :: FactionId -> LevelId -> ActorId -> Time -> ActorTime + -> ActorTime +updateActorTime !fid !lid !aid !time = + EM.adjust (EM.adjust (EM.insert aid time) lid) fid +ageActor :: FactionId -> LevelId -> ActorId -> Delta Time -> ActorTime + -> ActorTime +ageActor !fid !lid !aid !delta = + EM.adjust (EM.adjust (EM.adjust (`timeShift` delta) aid) lid) fid + instance Binary StateServer where put StateServer{..} = do put sactorTime - put sdiscoKind put sdiscoKindRev put suniqueSet - put sdiscoAspect put sitemSeedD put sitemRev put sflavour put sacounter put sicounter put snumSpawned - put sundo + put sclientStates put (show srandom) put srngs - put sdebugSer + put soptions get = do sactorTime <- get - sdiscoKind <- get sdiscoKindRev <- get suniqueSet <- get - sdiscoAspect <- get sitemSeedD <- get sitemRev <- get sflavour <- get sacounter <- get sicounter <- get snumSpawned <- get - sundo <- get + sclientStates <- get g <- get srngs <- get - sdebugSer <- get + soptions <- get let srandom = read g + sundo = [] sperFid = EM.empty sperValidFid = EM.empty sperCacheFid = EM.empty - sactorAspect = EM.empty sfovLucidLid = EM.empty sfovClearLid = EM.empty sfovLitLid = EM.empty @@ -217,53 +146,5 @@ svalidArenas = False squit = False swriteSave = False - sdebugNxt = defDebugModeSer + soptionsNxt = defServerOptions return $! StateServer{..} - -instance Binary DebugModeSer where - put DebugModeSer{..} = do - put sknowMap - put sknowEvents - put sknowItems - put sniffIn - put sniffOut - put sallClear - put sboostRandomItem - put sgameMode - put sautomateAll - put skeepAutomated - put scurChalSer - put ssavePrefixSer - put sdbgMsgSer - put sdebugCli - get = do - sknowMap <- get - sknowEvents <- get - sknowItems <- get - sniffIn <- get - sniffOut <- get - sallClear <- get - sboostRandomItem <- get - sgameMode <- get - sautomateAll <- get - skeepAutomated <- get - scurChalSer <- get - ssavePrefixSer <- get - sdbgMsgSer <- get - sdebugCli <- get - let sdungeonRng = Nothing - smainRng = Nothing - snewGameSer = False - sdumpInitRngs = False - return $! DebugModeSer{..} - -instance Binary RNGs where - put RNGs{..} = do - put (show dungeonRandomGenerator) - put (show startingRandomGenerator) - get = do - dg <- get - sg <- get - let dungeonRandomGenerator = read dg - startingRandomGenerator = read sg - return $! RNGs{..} diff --git a/GameDefinition/Client/UI/Content/KeyKind.hs b/GameDefinition/Client/UI/Content/KeyKind.hs --- a/GameDefinition/Client/UI/Content/KeyKind.hs +++ b/GameDefinition/Client/UI/Content/KeyKind.hs @@ -8,9 +8,9 @@ import Game.LambdaHack.Common.Prelude -import Game.LambdaHack.Client.UI.Content.KeyKind -import Game.LambdaHack.Client.UI.HumanCmd -import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Client.UI.Content.KeyKind +import Game.LambdaHack.Client.UI.HumanCmd +import Game.LambdaHack.Common.Misc import qualified Game.LambdaHack.Content.TileKind as TK -- | Description of default key-command bindings. @@ -18,230 +18,228 @@ -- In addition to these commands, mouse and keys have a standard meaning -- when navigating various menus. standardKeys :: KeyKind -standardKeys = KeyKind - { rhumanCommands = map evalKeyDef $ - -- All commands are defined here, except some movement and leader picking - -- commands. All commands are shown on help screens except debug commands - -- and macros with empty descriptions. - -- The order below determines the order on the help screens. - -- Remember to put commands that show information (e.g., enter aiming - -- mode) first. +standardKeys = KeyKind $ map evalKeyDef $ + -- All commands are defined here, except some movement and leader picking + -- commands. All commands are shown on help screens except debug commands + -- and macros with empty descriptions. + -- The order below determines the order on the help screens. + -- Remember to put commands that show information (e.g., enter aiming + -- mode) first. - -- Main Menu - [ ("c", ([CmdMainMenu], "enter challenges menu>", ChallengesMenu)) - , ("n", ([CmdMainMenu], "start new game", GameRestart)) - , ("x", ([CmdMainMenu], "save and exit", GameExit)) - , ("m", ([CmdMainMenu], "enter settings menu>", SettingsMenu)) - , ("a", ([CmdMainMenu], "automate faction", Automate)) - , ("?", ([CmdMainMenu], "see command Help", Help)) - , ("Escape", ([CmdMainMenu], "back to playing", Cancel)) + -- Main Menu + [ ("e", ([CmdMainMenu], "enter challenges menu>", ChallengesMenu)) + , ("s", ([CmdMainMenu], "start new game", GameRestart)) + , ("x", ([CmdMainMenu], "exit to desktop", GameExit)) + , ("v", ([CmdMainMenu], "visit settings menu>", SettingsMenu)) + , ("a", ([CmdMainMenu], "automate faction", Automate)) + , ("?", ([CmdMainMenu], "see command Help", Help)) + , ("Escape", ([CmdMainMenu], "back to playing", Cancel)) - -- Item use, 1st part - , ("g", addCmdCategory CmdMinimal $ grabItems "grab item(s)") - , ("comma", grabItems "") - , ("d", dropItems "drop item(s)") - , ("period", dropItems "") - , ("f", addCmdCategory CmdItemMenu $ projectA flingTs) - , ("C-f", addCmdCategory CmdItemMenu - $ replaceDesc "fling without aiming" $ projectI flingTs) - , ("a", addCmdCategory CmdItemMenu $ applyI [ApplyItem - { verb = "apply" - , object = "consumable" - , symbol = ' ' }]) - , ("C-a", addCmdCategory CmdItemMenu - $ replaceDesc "apply and keep choice" $ applyIK [ApplyItem - { verb = "apply" - , object = "consumable" - , symbol = ' ' }]) + -- Item use, 1st part + , ("g", addCmdCategory CmdMinimal $ grabItems "grab item(s)") + , ("comma", grabItems "") + , ("d", dropItems "drop item(s)") + , ("period", dropItems "") + , ("f", addCmdCategory CmdItemMenu $ projectA flingTs) + , ("C-f", addCmdCategory CmdItemMenu + $ replaceDesc "fling without aiming" $ projectI flingTs) + , ("a", addCmdCategory CmdItemMenu $ applyI [ApplyItem + { verb = "apply" + , object = "consumable" + , symbol = ' ' }]) + , ("C-a", addCmdCategory CmdItemMenu + $ replaceDesc "apply and keep choice" $ applyIK [ApplyItem + { verb = "apply" + , object = "consumable" + , symbol = ' ' }]) - -- Terrain exploration and alteration - , ("semicolon", ( [CmdMove] - , "go to x-hair for 25 steps" - , Macro ["C-semicolon", "C-/", "C-V"] )) - , ("colon", ( [CmdMove] - , "run to x-hair collectively for 25 steps" - , Macro ["C-colon", "C-/", "C-V"] )) - , ("x", ( [CmdMove] - , "explore nearest unknown spot" - , autoexploreCmd )) - , ("X", ( [CmdMove] - , "autoexplore 25 times" - , autoexplore25Cmd )) - , ("R", ([CmdMove], "rest (wait 25 times)", Macro ["KP_5", "C-V"])) - , ("C-R", ( [CmdMove], "lurk (wait 0.1 turns 100 times)" - , Macro ["C-KP_5", "V"] )) - , ("c", ( [CmdMove, CmdMinimal] - , descTs closeDoorTriggers - , AlterDir closeDoorTriggers )) + -- Terrain exploration and alteration + , ("semicolon", ( [CmdMove] + , "go to x-hair for 25 steps" + , Macro ["C-semicolon", "C-/", "C-V"] )) + , ("colon", ( [CmdMove] + , "run to x-hair collectively for 25 steps" + , Macro ["C-colon", "C-/", "C-V"] )) + , ("x", ( [CmdMove] + , "explore nearest unknown spot" + , autoexploreCmd )) + , ("X", ( [CmdMove] + , "autoexplore 25 times" + , autoexplore25Cmd )) + , ("R", ([CmdMove], "rest (wait 25 times)", Macro ["KP_5", "C-V"])) + , ("C-R", ( [CmdMove], "lurk (wait 0.1 turns 100 times)" + , Macro ["C-KP_5", "V"] )) + , ("c", ( [CmdMove, CmdMinimal] + , descTs closeDoorTriggers + , AlterDir closeDoorTriggers )) - -- Item use, continued - , ("^", ( [CmdItem], "sort items by kind and stats", SortSlots)) - , ("p", moveItemTriple [CGround, CEqp, CSha] CInv - "item" False) - , ("e", moveItemTriple [CGround, CInv, CSha] CEqp - "item" False) - , ("s", moveItemTriple [CGround, CInv, CEqp] CSha - "and share item" False) - , ("P", ( [CmdMinimal, CmdItem] - , "manage item pack of the leader" - , ChooseItemMenu (MStore CInv) )) - , ("G", ( [CmdItem] - , "manage items on the ground" - , ChooseItemMenu (MStore CGround) )) - , ("E", ( [CmdItem] - , "manage equipment of the leader" - , ChooseItemMenu (MStore CEqp) )) - , ("S", ( [CmdItem] - , "manage the shared party stash" - , ChooseItemMenu (MStore CSha) )) - , ("A", ( [CmdItem] - , "manage all owned items" - , ChooseItemMenu MOwned )) - , ("@", ( [CmdItem] - , "describe organs of the leader" - , ChooseItemMenu (MStore COrgan) )) - , ("#", ( [CmdItem] - , "show stat summary of the leader" - , ChooseItemMenu MStats )) - , ("~", ( [CmdItem] - , "display known lore" - , ChooseItemMenu MLoreItem )) - , ("q", addCmdCategory CmdItem $ applyI [ApplyItem - { verb = "quaff" - , object = "potion" - , symbol = '!' }]) - , ("r", addCmdCategory CmdItem $ applyI [ApplyItem - { verb = "read" - , object = "scroll" - , symbol = '?' }]) + -- Item use, continued + , ("^", ( [CmdItem], "sort items by kind and stats", SortSlots)) + , ("p", moveItemTriple [CGround, CEqp, CSha] CInv + "item" False) + , ("e", moveItemTriple [CGround, CInv, CSha] CEqp + "item" False) + , ("s", moveItemTriple [CGround, CInv, CEqp] CSha + "and share item" False) + , ("P", ( [CmdMinimal, CmdItem] + , "manage item pack of the leader" + , ChooseItemMenu (MStore CInv) )) + , ("G", ( [CmdItem] + , "manage items on the ground" + , ChooseItemMenu (MStore CGround) )) + , ("E", ( [CmdItem] + , "manage equipment of the leader" + , ChooseItemMenu (MStore CEqp) )) + , ("S", ( [CmdItem] + , "manage the shared party stash" + , ChooseItemMenu (MStore CSha) )) + , ("A", ( [CmdItem] + , "manage all owned items" + , ChooseItemMenu MOwned )) + , ("@", ( [CmdItem] + , "describe organs of the leader" + , ChooseItemMenu (MStore COrgan) )) + , ("#", ( [CmdItem] + , "show stat summary of the leader" + , ChooseItemMenu MStats )) + , ("~", ( [CmdItem] + , "display known lore" + , ChooseItemMenu MLoreItem )) + , ("q", addCmdCategory CmdItem $ applyI [ApplyItem + { verb = "quaff" + , object = "potion" + , symbol = '!' }]) + , ("r", addCmdCategory CmdItem $ applyI [ApplyItem + { verb = "read" + , object = "scroll" + , symbol = '?' }]) - , ("t", addCmdCategory CmdItem $ projectA - [ ApplyItem { verb = "throw" - , object = "missile" - , symbol = '|' } ]) --- , ("z", projectA [ApplyItem { verb = "zap" --- , object = "wand" --- , symbol = '/' }]) + , ("t", addCmdCategory CmdItem $ projectA + [ ApplyItem { verb = "throw" + , object = "missile" + , symbol = '|' } ]) +-- , ("z", projectA [ApplyItem { verb = "zap" +-- , object = "wand" +-- , symbol = '/' }]) - -- Aiming - , ("KP_Multiply", ( [CmdAim, CmdMinimal] - , "cycle x-hair among enemies", AimEnemy )) - -- not really minimal, because flinging from Item Menu enters aiming - -- mode, first screen mentions aiming mode not in fling context - , ("!", ([CmdAim], "", AimEnemy)) - , ("KP_Divide", ([CmdAim], "cycle x-hair among items", AimItem)) - , ("/", ([CmdAim], "", AimItem)) - , ("\\", ([CmdAim], "cycle aiming modes", AimFloor)) - , ("+", ([CmdAim, CmdMinimal], "swerve the aiming line", EpsIncr True)) - , ("-", ([CmdAim], "unswerve the aiming line", EpsIncr False)) - , ("C-?", ( [CmdAim] - , "set x-hair to nearest unknown spot" - , XhairUnknown )) - , ("C-I", ( [CmdAim] - , "set x-hair to nearest item" - , XhairItem )) - , ("C-{", ( [CmdAim] - , "set x-hair to nearest upstairs" - , XhairStair True )) - , ("C-}", ( [CmdAim] - , "set x-hair to nearest downstairs" - , XhairStair False )) - , ("<", ([CmdAim], "move aiming one level higher" , AimAscend 1)) - , ("C-<", ( [CmdNoHelp], "move aiming 10 levels higher" - , AimAscend 10) ) - , (">", ([CmdAim], "move aiming one level lower", AimAscend (-1))) - , ("C->", ( [CmdNoHelp], "move aiming 10 levels lower" - , AimAscend (-10)) ) - , ("BackSpace" , ( [CmdAim] - , "clear chosen item and target" - , ComposeUnlessError ItemClear TgtClear )) - , ("Escape", ( [CmdAim, CmdMinimal] - , "cancel aiming/open Main Menu" - , ByAimMode {exploration = MainMenu, aiming = Cancel} )) - , ("Return", ( [CmdAim, CmdMinimal] - , "accept target/open Help" - , ByAimMode {exploration = Help, aiming = Accept} )) + -- Aiming + , ("KP_Multiply", ( [CmdAim, CmdMinimal] + , "cycle x-hair among enemies", AimEnemy )) + -- not really minimal, because flinging from Item Menu enters aiming + -- mode, first screen mentions aiming mode not in fling context + , ("!", ([CmdAim], "", AimEnemy)) + , ("KP_Divide", ([CmdAim], "cycle x-hair among items", AimItem)) + , ("/", ([CmdAim], "", AimItem)) + , ("\\", ([CmdAim], "cycle aiming modes", AimFloor)) + , ("+", ([CmdAim, CmdMinimal], "swerve the aiming line", EpsIncr True)) + , ("-", ([CmdAim], "unswerve the aiming line", EpsIncr False)) + , ("C-?", ( [CmdAim] + , "set x-hair to nearest unknown spot" + , XhairUnknown )) + , ("C-I", ( [CmdAim] + , "set x-hair to nearest item" + , XhairItem )) + , ("C-{", ( [CmdAim] + , "set x-hair to nearest upstairs" + , XhairStair True )) + , ("C-}", ( [CmdAim] + , "set x-hair to nearest downstairs" + , XhairStair False )) + , ("<", ([CmdAim], "move aiming one level higher" , AimAscend 1)) + , ("C-<", ( [CmdNoHelp], "move aiming 10 levels higher" + , AimAscend 10) ) + , (">", ([CmdAim], "move aiming one level lower", AimAscend (-1))) + , ("C->", ( [CmdNoHelp], "move aiming 10 levels lower" + , AimAscend (-10)) ) + , ("BackSpace" , ( [CmdAim] + , "clear chosen item and target" + , ComposeUnlessError ItemClear TgtClear )) + , ("Escape", ( [CmdAim, CmdMinimal] + , "cancel aiming/open Main Menu" + , ByAimMode {exploration = MainMenu, aiming = Cancel} )) + , ("Return", ( [CmdAim, CmdMinimal] + , "accept target/open Help" + , ByAimMode {exploration = Help, aiming = Accept} )) - -- Assorted - , ("space", ( [CmdMinimal, CmdMeta] - , "clear messages/display history", Clear )) - , ("?", ([CmdMeta], "display Help", Help)) - , ("F1", ([CmdMeta], "", Help)) - , ("Tab", ( [CmdMeta] - , "cycle among party members on the level" - , MemberCycle )) - , ("BackTab", ( [CmdMeta, CmdMinimal] - , "cycle among all party members" - , MemberBack )) - , ("=", ( [CmdMinimal, CmdMeta] - , "select (or deselect) party member", SelectActor) ) - , ("_", ([CmdMeta], "deselect (or select) all on the level", SelectNone)) - , ("v", ([CmdMeta], "voice again the recorded commands", Repeat 1)) - , ("V", repeatTriple 100) - , ("C-v", repeatTriple 1000) - , ("C-V", repeatTriple 25) - , ("'", ([CmdMeta], "start recording commands", Record)) + -- Assorted + , ("space", ( [CmdMinimal, CmdMeta] + , "clear messages/display history", Clear )) + , ("?", ([CmdMeta], "display Help", Help)) + , ("F1", ([CmdMeta], "", Help)) + , ("Tab", ( [CmdMeta] + , "cycle among party members on the level" + , MemberCycle )) + , ("BackTab", ( [CmdMeta, CmdMinimal] + , "cycle among all party members" + , MemberBack )) + , ("=", ( [CmdMinimal, CmdMeta] + , "select (or deselect) party member", SelectActor) ) + , ("_", ([CmdMeta], "deselect (or select) all on the level", SelectNone)) + , ("v", ([CmdMeta], "voice again the recorded commands", Repeat 1)) + , ("V", repeatTriple 100) + , ("C-v", repeatTriple 1000) + , ("C-V", repeatTriple 25) + , ("'", ([CmdMeta], "start recording commands", Record)) - -- Mouse - , ("LeftButtonRelease", mouseLMB) - , ("RightButtonRelease", mouseRMB) - , ("C-LeftButtonRelease", replaceDesc "" mouseRMB) -- Mac convention - , ( "C-RightButtonRelease" - , ( [CmdMouse] - , "open or close door" - , AlterWithPointer $ closeDoorTriggers ++ openDoorTriggers ) ) - , ("MiddleButtonRelease", mouseMMB) - , ("WheelNorth", ([CmdMouse], "swerve the aiming line", Macro ["+"])) - , ("WheelSouth", ([CmdMouse], "unswerve the aiming line", Macro ["-"])) + -- Mouse + , ("LeftButtonRelease", mouseLMB) + , ("RightButtonRelease", mouseRMB) + , ("C-LeftButtonRelease", replaceDesc "" mouseRMB) -- Mac convention + , ( "C-RightButtonRelease" + , ( [CmdMouse] + , "open or close door" + , AlterWithPointer $ closeDoorTriggers ++ openDoorTriggers ) ) + , ("MiddleButtonRelease", mouseMMB) + , ("WheelNorth", ([CmdMouse], "swerve the aiming line", Macro ["+"])) + , ("WheelSouth", ([CmdMouse], "unswerve the aiming line", Macro ["-"])) - -- Debug and others not to display in help screens - , ("C-S", ([CmdDebug], "save game", GameSave)) - , ("C-semicolon", ( [CmdNoHelp] - , "move one step towards the x-hair" - , MoveOnceToXhair )) - , ("C-colon", ( [CmdNoHelp] - , "run collectively one step towards the x-hair" - , RunOnceToXhair )) - , ("C-/", ( [CmdNoHelp] - , "continue towards the x-hair" - , ContinueToXhair )) - , ("C-comma", ([CmdNoHelp], "run once ahead", RunOnceAhead)) - , ("safe1", ( [CmdInternal] - , "go to pointer for 25 steps" - , goToCmd )) - , ("safe2", ( [CmdInternal] - , "run to pointer collectively" - , runToAllCmd )) - , ("safe3", ( [CmdInternal] - , "pick new leader on screen" - , PickLeaderWithPointer )) - , ("safe4", ( [CmdInternal] - , "select party member on screen" - , SelectWithPointer )) - , ("safe5", ( [CmdInternal] - , "set x-hair to enemy" - , AimPointerEnemy )) - , ("safe6", ( [CmdInternal] - , "fling at enemy under pointer" - , aimFlingCmd )) - , ("safe7", ( [CmdInternal] - , "open Main Menu" - , MainMenu )) - , ("safe8", ( [CmdInternal] - , "cancel aiming" - , Cancel )) - , ("safe9", ( [CmdInternal] - , "accept target" - , Accept )) - , ("safe10", ( [CmdInternal] - , "wait a turn, bracing for impact" - , Wait )) - , ("safe11", ( [CmdInternal] - , "wait 0.1 of a turn" - , Wait10 )) - ] - ++ map defaultHeroSelect [0..6] - } + -- Debug and others not to display in help screens + , ("C-S", ([CmdDebug], "save game", GameSave)) + , ("C-semicolon", ( [CmdNoHelp] + , "move one step towards the x-hair" + , MoveOnceToXhair )) + , ("C-colon", ( [CmdNoHelp] + , "run collectively one step towards the x-hair" + , RunOnceToXhair )) + , ("C-/", ( [CmdNoHelp] + , "continue towards the x-hair" + , ContinueToXhair )) + , ("C-comma", ([CmdNoHelp], "run once ahead", RunOnceAhead)) + , ("safe1", ( [CmdInternal] + , "go to pointer for 25 steps" + , goToCmd )) + , ("safe2", ( [CmdInternal] + , "run to pointer collectively" + , runToAllCmd )) + , ("safe3", ( [CmdInternal] + , "pick new leader on screen" + , PickLeaderWithPointer )) + , ("safe4", ( [CmdInternal] + , "select party member on screen" + , SelectWithPointer )) + , ("safe5", ( [CmdInternal] + , "set x-hair to enemy" + , AimPointerEnemy )) + , ("safe6", ( [CmdInternal] + , "fling at enemy under pointer" + , aimFlingCmd )) + , ("safe7", ( [CmdInternal] + , "open Main Menu" + , MainMenu )) + , ("safe8", ( [CmdInternal] + , "cancel aiming" + , Cancel )) + , ("safe9", ( [CmdInternal] + , "accept target" + , Accept )) + , ("safe10", ( [CmdInternal] + , "wait a turn, bracing for impact" + , Wait )) + , ("safe11", ( [CmdInternal] + , "wait 0.1 of a turn" + , Wait10 )) + ] + ++ map defaultHeroSelect [0..6] closeDoorTriggers :: [Trigger] closeDoorTriggers = diff --git a/GameDefinition/Content/CaveKind.hs b/GameDefinition/Content/CaveKind.hs --- a/GameDefinition/Content/CaveKind.hs +++ b/GameDefinition/Content/CaveKind.hs @@ -1,4 +1,4 @@ --- | Cave layouts. +-- | Cave properties. module Content.CaveKind ( cdefs ) where @@ -33,21 +33,21 @@ , ("caveRogue", 1) ] , cxsize = fst normalLevelBound + 1 , cysize = snd normalLevelBound + 1 - , cgrid = DiceXY (3 * d 2) 4 - , cminPlaceSize = DiceXY (2 * d 2 + 4) 5 + , cgrid = DiceXY (3 `d` 2) 4 + , cminPlaceSize = DiceXY (2 `d` 2 + 4) 5 , cmaxPlaceSize = DiceXY 15 10 - , cdarkChance = d 54 + dl 20 + , cdarkChance = 1 `d` 54 + 1 `dl` 20 , cnightChance = 51 -- always night , cauxConnects = 1%2 , cmaxVoid = 1%6 , cminStairDist = 15 - , cextraStairs = 1 + d 2 + , cextraStairs = 1 + 1 `d` 2 , cdoorChance = 3%4 , copenChance = 1%5 , chidden = 7 , cactorCoeff = 130 -- the maze requires time to explore , cactorFreq = [("monster", 60), ("animal", 40)] - , citemNum = 6 * d 5 + , citemNum = 6 `d` 5 , citemFreq = [("useful", 40), ("treasure", 60)] , cplaceFreq = [("rogue", 100)] , cpassable = False @@ -60,64 +60,68 @@ , clegendLitTile = "legendLit" , cescapeGroup = Nothing , cstairFreq = [("staircase", 100)] + , cdesc = "" } -- no lit corridor alternative, because both lit # and . look bad here arena = rogue { csymbol = 'A' , cname = "Dusty underground library" , cfreq = [("default random", 40), ("caveArena", 1)] - , cgrid = DiceXY (2 + d 2) (d 3) - , cminPlaceSize = DiceXY (2 * d 2 + 4) 6 + , cgrid = DiceXY (2 + 1 `d` 2) (1 `d` 3) + , cminPlaceSize = DiceXY (2 `d` 2 + 4) 6 , cmaxPlaceSize = DiceXY 16 12 - , cdarkChance = 49 + d 10 -- almost all rooms dark (1 in 10 lit) + , cdarkChance = 49 + 1 `d` 10 -- almost all rooms dark (1 in 10 lit) -- Light is not too deadly, because not many obstructions and so -- foes visible from far away and few foes have ranged combat -- at shallow depth. , cnightChance = 0 -- always day , cauxConnects = 1 , cmaxVoid = 1%8 - , cextraStairs = d 3 + , cextraStairs = 1 `d` 3 , chidden = 0 , cactorCoeff = 100 , cactorFreq = [("monster", 30), ("animal", 70)] - , citemNum = 5 * d 5 -- few rooms + , citemNum = 5 `d` 5 -- few rooms , citemFreq = [("useful", 20), ("treasure", 40), ("any scroll", 40)] , cplaceFreq = [("arena", 100)] , cpassable = True , cdefTile = "arenaSetLit" , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" + , cdesc = "" } arena2 = arena { cname = "Smoking rooms" , cfreq = [("deep random", 30)] - , cdarkChance = 41 + d 10 -- almost all rooms lit (1 in 10 dark) + , cdarkChance = 41 + 1 `d` 10 -- almost all rooms lit (1 in 10 dark) -- Trails provide enough light for fun stealth. , cnightChance = 51 -- always night - , citemNum = 7 * d 5 -- rare, so make it exciting + , citemNum = 7 `d` 5 -- rare, so make it exciting , citemFreq = [("useful", 20), ("treasure", 40), ("any vial", 40)] , cdefTile = "arenaSetDark" + , cdesc = "" } laboratory = arena2 { csymbol = 'L' , cname = "Burnt laboratory" , cfreq = [("deep random", 20), ("caveLaboratory", 1)] - , cgrid = DiceXY (2 * d 2 + 7) 3 - , cminPlaceSize = DiceXY (3 * d 2 + 4) 5 - , cdarkChance = d 54 + dl 20 -- most rooms lit, to compensate for corridors + , cgrid = DiceXY (2 `d` 2 + 7) 3 + , cminPlaceSize = DiceXY (3 `d` 2 + 4) 5 + , cdarkChance = 1 `d` 54 + 1 `dl` 20 -- most rooms lit, to compensate for corridors , cnightChance = 0 -- always day , cauxConnects = 1%10 , cmaxVoid = 1%10 - , cextraStairs = d 2 + , cextraStairs = 1 `d` 2 , cdoorChance = 1 , copenChance = 1%2 , chidden = 7 - , citemNum = 7 * d 5 -- reward difficulty + , citemNum = 7 `d` 5 -- reward difficulty , citemFreq = [("useful", 20), ("treasure", 40), ("any vial", 40)] , cplaceFreq = [("laboratory", 100)] , cpassable = False , cdefTile = "fillerWall" , cdarkCorTile = "labTrailLit" -- let lab smoke give off light always , clitCorTile = "labTrailLit" + , cdesc = "An experiment (or was it manufacturing?) had gone wrong here." } empty = rogue { csymbol = 'E' @@ -126,16 +130,16 @@ , cgrid = DiceXY 1 1 , cminPlaceSize = DiceXY 12 12 , cmaxPlaceSize = DiceXY 48 32 -- favour large rooms - , cdarkChance = d 100 + dl 100 + , cdarkChance = 1 `d` 100 + 1 `dl` 100 , cnightChance = 0 -- always day , cauxConnects = 3%2 , cminStairDist = 30 , cmaxVoid = 0 -- too few rooms to have void and fog common anyway - , cextraStairs = d 2 + , cextraStairs = 1 `d` 2 , cdoorChance = 0 , copenChance = 0 , chidden = 0 - , cactorCoeff = 8 + , cactorCoeff = 7 , cactorFreq = [("animal", 10), ("immobile animal", 90)] -- The healing geysers on lvl 3 act like HP resets. Needed to avoid -- cascading failure, if the particular starting conditions were @@ -143,18 +147,19 @@ -- enough of a continuity. Gyesers on lvl 3 are not OP and can't be -- abused, because they spawn less and less often and also HP doesn't -- effectively accumulate over max. - , citemNum = 4 * d 5 -- few rooms and geysers are the boon + , citemNum = 4 `d` 5 -- few rooms and geysers are the boon , cplaceFreq = [("empty", 100)] , cpassable = True , cdefTile = "emptySet" , cdarkCorTile = "floorArenaDark" , clitCorTile = "floorArenaLit" + , cdesc = "" } noise = rogue { csymbol = 'N' , cname = "Leaky burrowed sediment" , cfreq = [("default random", 10), ("caveNoise", 1)] - , cgrid = DiceXY (2 + d 3) 3 + , cgrid = DiceXY (2 + 1 `d` 3) 3 , cminPlaceSize = DiceXY 8 5 , cmaxPlaceSize = DiceXY 20 10 , cdarkChance = 51 @@ -163,30 +168,33 @@ , cnightChance = 0 -- harder variant, but looks cheerful , cauxConnects = 1%10 , cmaxVoid = 1%100 - , cextraStairs = d 4 + , cextraStairs = 1 `d` 4 , cdoorChance = 1 -- to avoid lit quasi-door tiles , chidden = 0 , cactorCoeff = 160 -- the maze requires time to explore , cactorFreq = [("monster", 80), ("animal", 20)] - , citemNum = 7 * d 5 -- an incentive to explore the labyrinth + , citemNum = 7 `d` 5 -- an incentive to explore the labyrinth , cpassable = True , cplaceFreq = [("noise", 100)] , cdefTile = "noiseSet" , couterFenceTile = "noise fence" -- ensures no cut-off parts from collapsed , cdarkCorTile = "floorArenaDark" , clitCorTile = "floorArenaLit" + , cdesc = "" } noise2 = noise { cname = "Frozen derelict mine" , cfreq = [("caveNoise2", 1)] , cnightChance = 51 -- easier variant, but looks sinister - , citemNum = 13 * d 5 -- an incentive to explore the final labyrinth + , citemNum = 13 `d` 5 -- an incentive to explore the final labyrinth , cplaceFreq = [("noise", 1), ("mine", 99)] , cstairFreq = [("gated staircase", 100)] + , cdesc = "" } shallow2rogue = rogue { cfreq = [("shallow random 2", 100)] , cextraStairs = 1 -- ensure heroes meet initial monsters and their loot + , cdesc = "" } shallow1rogue = shallow2rogue { csymbol = 'B' @@ -195,9 +203,10 @@ , cdarkChance = 0 -- all rooms lit, for a gentle start , cextraStairs = 1 , cactorFreq = filter ((/= "monster") . fst) $ cactorFreq rogue - , citemNum = 8 * d 5 -- lure them in with loot + , citemNum = 8 `d` 5 -- lure them in with loot , citemFreq = filter ((/= "treasure") . fst) $ citemFreq rogue , cescapeGroup = Just "escape up" + , cdesc = "" } raid = rogue { csymbol = 'T' @@ -207,9 +216,10 @@ , cmaxVoid = 1%10 , cactorCoeff = 500 -- deep level with no kit, so slow spawning , cactorFreq = [("animal", 100)] - , citemNum = 6 * d 8 -- just one level, hard enemies, treasure + , citemNum = 6 `d` 8 -- just one level, hard enemies, treasure , citemFreq = [("useful", 33), ("gem", 33), ("currency", 33)] , cescapeGroup = Just "escape up" + , cdesc = "" } brawl = rogue -- many random solid tiles, to break LOS, since it's a day -- and this scenario is not focused on ranged combat; @@ -217,7 +227,7 @@ { csymbol = 'b' , cname = "Sunny woodland" , cfreq = [("caveBrawl", 1)] - , cgrid = DiceXY (2 * d 2 + 2) 3 + , cgrid = DiceXY (2 `d` 2 + 2) 3 , cminPlaceSize = DiceXY 3 3 , cmaxPlaceSize = DiceXY 7 5 , cdarkChance = 51 @@ -227,13 +237,14 @@ , cextraStairs = 1 , chidden = 0 , cactorFreq = [] - , citemNum = 5 * d 8 + , citemNum = 5 `d` 8 , citemFreq = [("useful", 100)] , cplaceFreq = [("brawl", 60), ("rogue", 40)] , cpassable = True , cdefTile = "brawlSetLit" , cdarkCorTile = "floorArenaLit" , clitCorTile = "floorArenaLit" + , cdesc = "" } shootout = rogue -- a scenario with strong missiles; -- few solid tiles, but only translucent tiles or walkable @@ -243,7 +254,7 @@ { csymbol = 'S' , cname = "Misty meadow" , cfreq = [("caveShootout", 1)] - , cgrid = DiceXY (d 2 + 7) 3 + , cgrid = DiceXY (1 `d` 2 + 7) 3 , cminPlaceSize = DiceXY 3 3 , cmaxPlaceSize = DiceXY 3 4 , cdarkChance = 51 @@ -253,20 +264,21 @@ , cextraStairs = 1 , chidden = 0 , cactorFreq = [] - , citemNum = 5 * d 16 + , citemNum = 5 `d` 16 -- less items in inventory, more to be picked up, -- to reward explorer and aggressor and punish camper , citemFreq = [ ("useful", 30) , ("any arrow", 400), ("harpoon", 300) , ("any vial", 60) ] -- Many consumable buffs are needed in symmetric maps - -- so that aggresor prepares them in advance and camper + -- so that aggressor prepares them in advance and camper -- needs to waste initial turns to buff for the defence. , cplaceFreq = [("shootout", 100)] , cpassable = True , cdefTile = "shootoutSetLit" , cdarkCorTile = "floorArenaLit" , clitCorTile = "floorArenaLit" + , cdesc = "" } escape = rogue -- a scenario with weak missiles, because heroes don't depend -- on them; dark, so solid obstacles are to hide from missiles, @@ -275,8 +287,8 @@ { csymbol = 'E' , cname = "Metropolitan park at dusk" -- "night" didn't fit , cfreq = [("caveEscape", 1)] - , cgrid = DiceXY -- (2 * d 2 + 3) 4 -- park, so lamps in lines - (2 * d 2 + 6) 3 -- for now, to fit larger places + , cgrid = DiceXY -- (2 `d` 2 + 3) 4 -- park, so lamps in lines + (2 `d` 2 + 6) 3 -- for now, to fit larger places , cminPlaceSize = DiceXY 3 3 , cmaxPlaceSize = DiceXY 9 9 -- bias towards larger lamp areas , cdarkChance = 51 -- colonnade rooms should always be dark @@ -286,7 +298,7 @@ , cextraStairs = 1 , chidden = 0 , cactorFreq = [] - , citemNum = 6 * d 8 + , citemNum = 6 `d` 8 , citemFreq = [ ("useful", 30), ("treasure", 30), ("gem", 100) , ("weak arrow", 500), ("harpoon", 400) ] , cplaceFreq = [("park", 100)] -- the same rooms as in ambush @@ -295,12 +307,13 @@ , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" , cescapeGroup = Just "escape outdoor down" + , cdesc = "" } zoo = rogue -- few lights and many solids, to help the less numerous heroes { csymbol = 'Z' , cname = "Menagerie in flames" , cfreq = [("caveZoo", 1)] - , cgrid = DiceXY (2 * d 2 + 6) 3 + , cgrid = DiceXY (2 `d` 2 + 6) 3 , cminPlaceSize = DiceXY 4 4 , cmaxPlaceSize = DiceXY 12 12 , cdarkChance = 51 -- always dark rooms @@ -312,13 +325,14 @@ , cextraStairs = 1 , chidden = 0 , cactorFreq = [] - , citemNum = 7 * d 8 + , citemNum = 7 `d` 8 , citemFreq = [("useful", 100), ("light source", 1000)] , cplaceFreq = [("zoo", 50)] , cpassable = True , cdefTile = "zooSet" , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" + , cdesc = "" } ambush = rogue -- a scenario with strong missiles; -- dark, so solid obstacles are to hide from missiles, @@ -332,8 +346,8 @@ { csymbol = 'M' , cname = "Burning metropolitan park" , cfreq = [("caveAmbush", 1)] - , cgrid = DiceXY -- (2 * d 2 + 3) 4 -- park, so lamps in lines - (2 * d 2 + 5) 3 -- for now, to fit larger places + , cgrid = DiceXY -- (2 `d` 2 + 3) 4 -- park, so lamps in lines + (2 `d` 2 + 5) 3 -- for now, to fit larger places , cminPlaceSize = DiceXY 3 3 , cmaxPlaceSize = DiceXY 9 9 -- bias towards larger lamp areas , cdarkChance = 51 -- colonnade rooms should always be dark @@ -343,19 +357,20 @@ , cextraStairs = 1 , chidden = 0 , cactorFreq = [] - , citemNum = 5 * d 8 + , citemNum = 5 `d` 8 , citemFreq = [("useful", 30), ("any arrow", 400), ("harpoon", 300)] , cplaceFreq = [("park", 100)] , cpassable = True , cdefTile = "ambushSet" , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" + , cdesc = "" } battle = rogue -- few lights and many solids, to help the less numerous heroes { csymbol = 'B' , cname = "Old battle ground" , cfreq = [("caveBattle", 1)] - , cgrid = DiceXY (2 * d 2 + 1) 3 + , cgrid = DiceXY (2 `d` 2 + 1) 3 , cminPlaceSize = DiceXY 4 4 , cmaxPlaceSize = DiceXY 9 7 , cdarkChance = 0 @@ -367,7 +382,7 @@ , cextraStairs = 1 , chidden = 0 , cactorFreq = [] - , citemNum = 5 * d 8 + , citemNum = 5 `d` 8 , citemFreq = [("useful", 100), ("light source", 200)] , cplaceFreq = [("battle", 50), ("rogue", 50)] , cpassable = True @@ -375,20 +390,25 @@ , cdarkCorTile = "trailLit" -- let trails give off light , clitCorTile = "trailLit" , couterFenceTile = "noise fence" -- ensures no cut-off parts from collapsed + , cdesc = "" } safari1 = brawl - { cname = "Hunam habitat" - , cfreq = [("caveSafari1", 1)] - , cescapeGroup = Nothing - , cstairFreq = [("staircase outdoor", 1)] + { cname = "Hunam habitat" + , cfreq = [("caveSafari1", 1)] + , cescapeGroup = Nothing + , cstairFreq = [("staircase outdoor", 1)] + , cdesc = "\"Act 1. Hunams scavenge in a forest in their usual disgusting way.\"" } -safari2 = ambush - { cname = "Hunting grounds" - , cfreq = [("caveSafari2", 1)] - , cstairFreq = [("staircase outdoor", 1)] +safari2 = ambush -- lamps instead of trees, but ok, it's only a simulation + { cname = "Deep into the jungle" + , cfreq = [("caveSafari2", 1)] + , cstairFreq = [("staircase outdoor", 1)] + , cdesc = "\"Act 2. In the dark pure heart of the jungle noble animals roam freely.\"" } -safari3 = zoo - { cfreq = [("caveSafari3", 1)] - , cescapeGroup = Just "escape outdoor down" - , cstairFreq = [("staircase outdoor", 1)] +safari3 = zoo -- glass rooms, but ok, it's only a simulation + { cname = "Jungle in flames" + , cfreq = [("caveSafari3", 1)] + , cescapeGroup = Just "escape outdoor down" + , cstairFreq = [("staircase outdoor", 1)] + , cdesc = "\"Act 3. Jealous hunams set jungle on fire and flee.\"" } diff --git a/GameDefinition/Content/ItemKind.hs b/GameDefinition/Content/ItemKind.hs --- a/GameDefinition/Content/ItemKind.hs +++ b/GameDefinition/Content/ItemKind.hs @@ -1,4 +1,4 @@ --- | Item and treasure definitions. +-- | Item definitions. module Content.ItemKind ( cdefs, items, otherItemContent ) where @@ -27,7 +27,7 @@ , getFreq = ifreq , validateSingle = validateSingleItemKind , validateAll = validateAllItemKind - , content = contentFromList [] -- filled out later on + , content = contentFromList $ items ++ otherItemContent } otherItemContent :: [ItemKind] @@ -74,12 +74,12 @@ , iname = "sandstone rock" , ifreq = [("sandstone rock", 1), ("weak arrow", 10)] , iflavour = zipPlain [Green] - , icount = 1 * d 2 + , icount = 1 `d` 2 , irarity = [(1, 50), (10, 1)] , iverbHit = "hit" , iweight = 300 - , idamage = toDmg $ 1 * d 1 - , iaspects = [AddHurtMelee (-16 |*| 5)] + , idamage = toDmg $ 1 `d` 1 + , iaspects = [AddHurtMelee $ -16 * 5] , ieffects = [] , ifeature = [toVelocity 70, Fragile, Identified] -- not dense, irregular , idesc = "A lump of brittle sandstone rock." @@ -90,12 +90,13 @@ , iname = "dart" , ifreq = [("useful", 100), ("any arrow", 50), ("weak arrow", 50)] , iflavour = zipPlain [BrRed] - , icount = 4 * d 3 + , icount = 4 `d` 3 , irarity = [(1, 20), (10, 10)] , iverbHit = "prick" , iweight = 40 - , idamage = toDmg $ 1 * d 1 - , iaspects = [AddHurtMelee (-14 + d 2 + dl 4 |*| 5)] -- only leather-piercing + , idamage = [(98, 1 `d` 1), (2, 2 `d` 1)] + , iaspects = [AddHurtMelee $ (-14 + 1 `d` 2 + 1 `dl` 4) * 5] + -- only leather-piercing , ieffects = [] , ifeature = [Identified] , idesc = "A sharp delicate dart with fins." @@ -106,12 +107,13 @@ , iname = "spike" , ifreq = [("useful", 100), ("any arrow", 50), ("weak arrow", 50)] , iflavour = zipPlain [Cyan] - , icount = 4 * d 3 + , icount = 4 `d` 3 , irarity = [(1, 10), (10, 20)] , iverbHit = "nick" , iweight = 150 - , idamage = toDmg $ 2 * d 1 - , iaspects = [AddHurtMelee (-10 + d 2 + dl 4 |*| 5)] -- heavy vs armor + , idamage = [(98, 2 `d` 1), (2, 4 `d` 1)] + , iaspects = [AddHurtMelee $ (-10 + 1 `d` 2 + 1 `dl` 4) * 5] + -- heavy vs armor , ieffects = [ Explode "single spark" -- when hitting enemy , OnSmash (Explode "single spark") ] -- at wall hit , ifeature = [toVelocity 70, Identified] -- hitting with tip costs speed @@ -123,12 +125,13 @@ , iname = "sling stone" , ifreq = [("useful", 5), ("any arrow", 100)] , iflavour = zipPlain [Blue] - , icount = 3 * d 3 + , icount = 3 `d` 3 , irarity = [(1, 1), (10, 20)] , iverbHit = "hit" , iweight = 200 - , idamage = toDmg $ 1 * d 1 - , iaspects = [AddHurtMelee (-10 + d 2 + dl 4 |*| 5)] -- heavy vs armor + , idamage = toDmg $ 1 `d` 1 + , iaspects = [AddHurtMelee $ (-10 + 1 `d` 2 + 1 `dl` 4) * 5] + -- heavy vs armor , ieffects = [ Explode "single spark" -- when hitting enemy , OnSmash (Explode "single spark") ] -- at wall hit , ifeature = [toVelocity 150, Identified] @@ -140,12 +143,13 @@ , iname = "sling bullet" , ifreq = [("useful", 5), ("any arrow", 100)] , iflavour = zipPlain [BrBlack] - , icount = 6 * d 3 + , icount = 6 `d` 3 , irarity = [(1, 1), (10, 15)] , iverbHit = "hit" , iweight = 28 - , idamage = toDmg $ 1 * d 1 - , iaspects = [AddHurtMelee (-17 + d 2 + dl 4 |*| 5)] -- not armor-piercing + , idamage = toDmg $ 1 `d` 1 + , iaspects = [AddHurtMelee $ (-17 + 1 `d` 2 + 1 `dl` 4) * 5] + -- not armor-piercing , ieffects = [] , ifeature = [toVelocity 200, Identified] , idesc = "Small almond-shaped leaden projectile that weighs more than the sling used to tie the bag. It doesn't drop out of the sling's pouch when swung and doesn't snag when released." @@ -160,12 +164,12 @@ , iname = "bolas set" , ifreq = [("useful", 100)] , iflavour = zipPlain [BrYellow] - , icount = dl 4 + , icount = 1 `dl` 4 , irarity = [(5, 5), (10, 5)] , iverbHit = "entangle" , iweight = 500 - , idamage = toDmg $ 1 * d 1 - , iaspects = [AddHurtMelee (-14 |*| 5)] + , idamage = toDmg $ 1 `d` 1 + , iaspects = [AddHurtMelee $ -14 * 5] , ieffects = [Paralyze 15, DropBestWeapon] , ifeature = [Identified] , idesc = "Wood balls tied with hemp rope. The target enemy is tripped and bound to drop the main weapon, while fighting for balance." @@ -176,12 +180,12 @@ , iname = "harpoon" , ifreq = [("useful", 100), ("harpoon", 100)] , iflavour = zipPlain [Brown] - , icount = dl 5 + , icount = 1 `dl` 5 , irarity = [(10, 10)] , iverbHit = "hook" , iweight = 750 - , idamage = [(99, 5 * d 1), (1, 10 * d 1)] - , iaspects = [AddHurtMelee (-10 + d 2 + dl 4 |*| 5)] + , idamage = [(99, 5 `d` 1), (1, 10 `d` 1)] + , iaspects = [AddHurtMelee $ (-10 + 1 `d` 2 + 1 `dl` 4) * 5] , ieffects = [PullActor (ThrowMod 200 50)] , ifeature = [Identified] , idesc = "The cruel, barbed head lodges in its victim so painfully that the weakest tug of the thin line sends the victim flying." @@ -192,13 +196,13 @@ , iname = "net" , ifreq = [("useful", 100)] , iflavour = zipPlain [White] - , icount = dl 3 + , icount = 1 `dl` 3 , irarity = [(3, 5), (10, 4)] , iverbHit = "entangle" , iweight = 1000 - , idamage = toDmg $ 2 * d 1 - , iaspects = [AddHurtMelee (-14 |*| 5)] - , ieffects = [ toOrganGameTurn "slowed" (3 + d 3) + , idamage = toDmg $ 2 `d` 1 + , iaspects = [AddHurtMelee $ -14 * 5] + , ieffects = [ toOrganGameTurn "slowed" (3 + 1 `d` 3) , DropItem maxBound 1 CEqp "torso armor" ] , ifeature = [Identified] , idesc = "A wide net with weights along the edges. Entangles armor and restricts movement." @@ -212,7 +216,7 @@ , iname = "wooden torch" , ifreq = [("useful", 100), ("light source", 100), ("wooden torch", 1)] , iflavour = zipPlain [Brown] - , icount = d 2 + , icount = 1 `d` 2 , irarity = [(1, 15)] , iverbHit = "scorch" , iweight = 1000 @@ -233,7 +237,7 @@ , irarity = [(6, 7)] , iverbHit = "burn" , iweight = 1500 - , idamage = toDmg $ 1 * d 1 + , idamage = toDmg $ 1 `d` 1 , iaspects = [AddShine 3, AddSight (-1)] , ieffects = [ Burn 1, Paralyze 6, OnSmash (Explode "burning oil 2") , EqpSlot EqpSlotLightSource ] @@ -250,7 +254,7 @@ , irarity = [(10, 5)] , iverbHit = "burn" , iweight = 3000 - , idamage = toDmg $ 4 * d 1 + , idamage = toDmg $ 4 `d` 1 , iaspects = [AddShine 4, AddSight (-1)] , ieffects = [ Burn 1, Paralyze 8, OnSmash (Explode "burning oil 4") , EqpSlot EqpSlotLightSource ] @@ -309,28 +313,28 @@ flask1 = flask { irarity = [(10, 4)] , ieffects = [ ELabel "of strength renewal brew" - , toOrganActorTurn "strengthened" (20 + d 5) + , toOrganActorTurn "strengthened" (20 + 1 `d` 5) , toOrganNone "regenerating" , OnSmash (Explode "dense shower") ] } flask2 = flask { ieffects = [ ELabel "of weakness brew" - , toOrganGameTurn "weakened" (20 + d 5) + , toOrganGameTurn "weakened" (20 + 1 `d` 5) , OnSmash (Explode "sparse shower") ] } flask3 = flask { ieffects = [ ELabel "of melee protective balm" - , toOrganActorTurn "protected from melee" (20 + d 5) + , toOrganActorTurn "protected from melee" (20 + 1 `d` 5) , OnSmash (Explode "melee protective balm") ] } flask4 = flask { ieffects = [ ELabel "of ranged protective balm" - , toOrganActorTurn "protected from ranged" (20 + d 5) + , toOrganActorTurn "protected from ranged" (20 + 1 `d` 5) , OnSmash (Explode "ranged protective balm") ] } flask5 = flask { ieffects = [ ELabel "of PhD defense questions" - , toOrganGameTurn "defenseless" (20 + d 5) + , toOrganGameTurn "defenseless" (20 + 1 `d` 5) , Impress , DetectExit 20 , OnSmash (Explode "PhD defense question") ] @@ -338,7 +342,7 @@ flask6 = flask { irarity = [(10, 9)] , ieffects = [ ELabel "of resolution" - , toOrganActorTurn "resolute" (200 + d 50) + , toOrganActorTurn "resolute" (200 + 1 `d` 50) -- long, for scouting and has to recharge , RefillCalm 60 -- not to make it a drawback, via @calmEnough@ , OnSmash (Explode "resolution dust") ] @@ -346,14 +350,14 @@ flask7 = flask { irarity = [(10, 4)] , ieffects = [ ELabel "of haste brew" - , toOrganActorTurn "hasted" (20 + d 5) + , toOrganActorTurn "hasted" (20 + 1 `d` 5) , OnSmash (Explode "blast 20") , OnSmash (Explode "haste spray") ] } flask8 = flask { irarity = [(1, 14), (10, 4)] , ieffects = [ ELabel "of lethargy brew" - , toOrganGameTurn "slowed" (20 + d 5) + , toOrganGameTurn "slowed" (20 + 1 `d` 5) , toOrganNone "regenerating", toOrganNone "regenerating" -- x2 , RefillCalm 5 , OnSmash (Explode "slowness mist") ] @@ -361,32 +365,32 @@ flask9 = flask { irarity = [(10, 4)] , ieffects = [ ELabel "of eye drops" - , toOrganActorTurn "far-sighted" (40 + d 10) + , toOrganActorTurn "far-sighted" (40 + 1 `d` 10) , OnSmash (Explode "eye drop") ] } flask10 = flask { irarity = [(10, 2)] , ieffects = [ ELabel "of smelly concoction" - , toOrganActorTurn "keen-smelling" (40 + d 10) + , toOrganActorTurn "keen-smelling" (40 + 1 `d` 10) , DetectActor 10 , OnSmash (Explode "smelly droplet") ] } flask11 = flask { irarity = [(10, 4)] , ieffects = [ ELabel "of cat tears" - , toOrganActorTurn "shiny-eyed" (40 + d 10) + , toOrganActorTurn "shiny-eyed" (40 + 1 `d` 10) , OnSmash (Explode "eye shine") ] } flask12 = flask { irarity = [(1, 14), (10, 10)] , ieffects = [ ELabel "of whiskey" - , toOrganActorTurn "drunk" (20 + d 5) + , toOrganActorTurn "drunk" (20 + 1 `d` 5) , Burn 1, RefillHP 3 , OnSmash (Explode "whiskey spray") ] } flask13 = flask { ieffects = [ ELabel "of bait cocktail" - , toOrganActorTurn "drunk" (20 + d 5) + , toOrganActorTurn "drunk" (20 + 1 `d` 5) , Burn 1, RefillHP 3 , Summon "mobile animal" 1 , OnSmash (Summon "mobile animal" 1) @@ -429,14 +433,14 @@ } flask19 = flask { ieffects = [ ELabel "of blindness" - , toOrganGameTurn "blind" (40 + d 10) + , toOrganGameTurn "blind" (40 + 1 `d` 10) , OnSmash (Explode "iron filing") ] } flask20 = flask { ieffects = [ ELabel "of calamity" , toOrganNone "poisoned" - , toOrganGameTurn "weakened" (20 + d 5) - , toOrganGameTurn "defenseless" (20 + d 5) + , toOrganGameTurn "weakened" (20 + 1 `d` 5) + , toOrganGameTurn "defenseless" (20 + 1 `d` 5) , OnSmash (Explode "poison cloud") ] } @@ -482,7 +486,8 @@ potion5 = potion -- needs to be common to show at least a portion of effects { irarity = [(1, 30), (10, 15)] , ieffects = [ OneOf [ RefillHP 10, RefillHP 5, Burn 5 - , toOrganActorTurn "strengthened" (20 + d 5) ] + , DropItem 1 maxBound COrgan "poisoned" + , toOrganActorTurn "strengthened" (20 + 1 `d` 5) ] , OnSmash (OneOf [ Explode "dense shower" , Explode "sparse shower" , Explode "melee protective balm" @@ -495,7 +500,8 @@ , ieffects = [ Impress , OneOf [ RefillCalm (-60) , RefillHP 20, RefillHP 10, Burn 10 - , toOrganActorTurn "hasted" (20 + d 5) ] + , DropItem 1 maxBound COrgan "poisoned" + , toOrganActorTurn "hasted" (20 + 1 `d` 5) ] , OnSmash (OneOf [ Explode "healing mist 2" , Explode "wounding mist" , Explode "distressing odor" @@ -551,11 +557,12 @@ { ifreq = [("treasure", 100)] , irarity = [(5, 9), (10, 9)] -- mixed blessing, so available early , ieffects = [ Unique, ELabel "of Reckless Beacon" - , Summon "hero" 1, Summon "mobile animal" (2 + d 2) ] + , Summon "hero" 1, Summon "mobile animal" (2 + 1 `d` 2) ] + , idesc = "The bright flame and sweet-smelling smoke of this heavily infused scroll should attract natural creatures inhabiting the area, including human survivors, if any." } scroll2 = scroll { irarity = [(1, 2)] - , ieffects = [ ELabel "of greed", Teleport 20, DetectItem 20 + , ieffects = [ ELabel "of greed", DetectItem 20, Teleport 20 , RefillCalm (-100) ] } scroll3 = scroll @@ -583,21 +590,25 @@ } scroll8 = scroll { irarity = [(10, 2)] - , ieffects = [InsertMove $ 1 + d 2 + dl 2] + , ieffects = [InsertMove $ 1 + 1 `d` 2 + 1 `dl` 2] } scroll9 = scroll { irarity = [(1, 30)] - , ieffects = [ELabel "of scientific explanation", Identify] + , ieffects = [ ELabel "of scientific explanation" + , Composite [Identify, RefillCalm 10] ] + -- your most pressing existential concerns are answered scientifitically, + -- hence the calming effect } scroll10 = scroll { irarity = [(10, 20)] , ieffects = [ ELabel "transfiguration" - , PolyItem, Explode "firecracker 7" ] + , Composite [PolyItem, Explode "firecracker 7"] ] } scroll11 = scroll { ifreq = [("treasure", 100)] , irarity = [(6, 9), (10, 9)] - , ieffects = [Unique, ELabel "of Prisoner Release", Summon "hero" 1] + , ieffects = [Unique, ELabel "of Rescue Proclamation", Summon "hero" 1] + , idesc = "A survivor is found that enjoys, apparently, complete physiological integrity. If we so wish, we can pronounce him rescued and let him join our team." } scroll12 = scroll { irarity = [(1, 9), (10, 4)] @@ -619,7 +630,7 @@ , iverbHit = "prod" , iweight = 10000 , idamage = toDmg 0 - , iaspects = [Timeout $ d 2 + 2 - dl 2 |*| 10] + , iaspects = [Timeout $ (1 `d` 2 + 2 - 1 `dl` 2) * 10] , ieffects = [Recharging (toOrganActorTurn "hasted" 1)] , ifeature = [Durable, Applicable, Identified] , idesc = "Makes you vulnerable at take-off, but then you are free like a bird." @@ -635,7 +646,7 @@ , iverbHit = "smack" , iweight = 400 , idamage = toDmg 0 - , iaspects = [AddHurtMelee $ d 10 |*| 3] + , iaspects = [AddHurtMelee $ (1 `d` 10) * 3] , ieffects = [EqpSlot EqpSlotAddHurtMelee] , ifeature = [Identified, Equipable] , idesc = "A portable sharpening stone that lets you fix your weapons between or even during fights, without the need to set up camp, fish out tools and assemble a proper sharpening workshop." @@ -652,7 +663,7 @@ , iweight = 100 , idamage = toDmg 0 , iaspects = [ AddSight 10, AddMaxCalm 30, AddShine 2 - , Timeout $ 1 + d 2 ] + , Timeout $ 1 + 1 `d` 2 ] , ieffects = [ Periodic , Recharging (toOrganNone "poisoned") , Recharging (Summon "mobile monster" 1) ] @@ -671,7 +682,7 @@ , iweight = 300 , idamage = toDmg 0 , iaspects = [ AddNocto 1 - , AddArmorMelee (dl 5 - 10), AddArmorRanged (dl 5 - 10) ] + , AddArmorMelee (1 `dl` 5 - 10), AddArmorRanged (1 `dl` 5 - 10) ] , ieffects = [EqpSlot EqpSlotMiscBonus] , ifeature = [Identified, Equipable] , idesc = "A silk flag with a bell for detecting sudden draft changes. May indicate a nearby corridor crossing or a fast enemy approaching in the dark. Is also very noisy." @@ -690,9 +701,9 @@ , iverbHit = "whip" , iweight = 30 , idamage = toDmg 0 - , iaspects = [ Timeout $ 1 + d 2 - , AddArmorMelee $ 2 + d 3 - , AddArmorRanged $ d 3 ] + , iaspects = [ Timeout $ 1 + 1 `d` 2 + , AddArmorMelee $ 2 + 1 `d` 3 + , AddArmorRanged $ 1 `d` 3 ] , ieffects = [ Unique, Periodic , Recharging (RefillCalm 1), EqpSlot EqpSlotMiscBonus ] , ifeature = [Durable, Precious, Identified, Equipable] @@ -718,7 +729,7 @@ } necklace1 = necklace { ifreq = [("treasure", 100)] - , iaspects = [Timeout $ d 3 + 4 - dl 3 |*| 10] + , iaspects = [Timeout $ (1 `d` 3 + 4 - 1 `dl` 3) * 10] , ieffects = [ Unique, ELabel "of Aromata", EqpSlot EqpSlotMiscBonus , Recharging (RefillHP 1) ] ++ ieffects necklace @@ -728,57 +739,57 @@ necklace2 = necklace { ifreq = [("treasure", 100)] -- just too nasty to call it useful , irarity = [(1, 1)] - , iaspects = [Timeout $ d 3 + 3 - dl 3 |*| 10] - , ieffects = [ Recharging (Summon "mobile animal" $ 1 + dl 2) + , iaspects = [Timeout $ (1 `d` 3 + 3 - 1 `dl` 3) * 10] + , ieffects = [ Recharging (Summon "mobile animal" $ 1 + 1 `dl` 2) , Recharging (Explode "waste") , Recharging Impress , Recharging (DropItem 1 maxBound COrgan "temporary condition") ] ++ ieffects necklace } necklace3 = necklace - { iaspects = [Timeout $ d 3 + 4 - dl 3 |*| 5] + { iaspects = [Timeout $ (1 `d` 3 + 4 - 1 `dl` 3) * 5] , ieffects = [ ELabel "of fearful listening" , Recharging (DetectActor 10) , Recharging (RefillCalm (-20)) ] ++ ieffects necklace } necklace4 = necklace - { iaspects = [Timeout $ d 4 + 4 - dl 4 |*| 2] - , ieffects = [Recharging (Teleport $ d 2 * 3)] + { iaspects = [Timeout $ (1 `d` 4 + 4 - 1 `dl` 4) * 2] + , ieffects = [Recharging (Teleport $ 3 `d` 2)] ++ ieffects necklace } necklace5 = necklace - { iaspects = [Timeout $ d 3 + 4 - dl 3 |*| 10] + { iaspects = [Timeout $ (1 `d` 3 + 4 - 1 `dl` 3) * 10] , ieffects = [ ELabel "of escape" - , Recharging (Teleport $ 14 + d 3 * 3) + , Recharging (Teleport $ 14 + 3 `d` 3) , Recharging (DetectExit 20) , Recharging (RefillHP (-2)) ] -- prevent micromanagement ++ ieffects necklace } necklace6 = necklace - { iaspects = [Timeout $ d 3 + 1 |*| 2] + { iaspects = [Timeout $ (1 `d` 3 + 1) * 2] , ieffects = [Recharging (PushActor (ThrowMod 100 50))] ++ ieffects necklace } necklace7 = necklace { ifreq = [("treasure", 100)] - , iaspects = [ AddMaxHP $ 10 + d 10 + , iaspects = [ AddMaxHP $ 10 + 1 `d` 10 , AddArmorMelee 20, AddArmorRanged 10 - , Timeout $ d 2 + 5 - dl 3 ] + , Timeout $ 1 `d` 2 + 5 - 1 `dl` 3 ] , ieffects = [ Unique, ELabel "of Overdrive", EqpSlot EqpSlotAddSpeed - , Recharging (InsertMove $ 1 + d 2) + , Recharging (InsertMove $ 1 + 1 `d` 2) , Recharging (RefillHP (-1)) , Recharging (RefillCalm (-1)) ] -- fake "hears something" :) ++ ieffects necklace , ifeature = Durable : ifeature necklace } necklace8 = necklace - { iaspects = [Timeout $ d 3 + 3 - dl 3 |*| 5] + { iaspects = [Timeout $ (1 `d` 3 + 3 - 1 `dl` 3) * 5] , ieffects = [Recharging $ Explode "spark"] ++ ieffects necklace } necklace9 = necklace - { iaspects = [Timeout $ d 3 + 3 - dl 3 |*| 5] + { iaspects = [Timeout $ (1 `d` 3 + 3 - 1 `dl` 3) * 5] , ieffects = [Recharging $ Explode "fragrance"] ++ ieffects necklace } @@ -795,7 +806,7 @@ , iverbHit = "bang" , iweight = 500 , idamage = toDmg 0 - , iaspects = [AddNocto 1, AddSight (-1), AddArmorMelee $ 1 + dl 3 |*| 3] + , iaspects = [AddNocto 1, AddSight (-1), AddArmorMelee $ (1 + 1 `dl` 3) * 3] , ieffects = [EqpSlot EqpSlotMiscBonus] , ifeature = [Precious, Identified, Durable, Equipable] , idesc = "Contraption of lenses and mirrors on a polished brass headband for capturing and strengthening light in dark environment. Hampers vision in daylight. Stackable." @@ -811,7 +822,7 @@ , iverbHit = "rap" , iweight = 50 , idamage = toDmg 0 - , iaspects = [AddSight $ 1 + d 2, AddHurtMelee $ d 2 |*| 3] + , iaspects = [AddSight $ 1 + 1 `d` 2, AddHurtMelee $ (1 `d` 2) * 3] , ieffects = [EqpSlot EqpSlotAddSight] , ifeature = [Precious, Identified, Durable, Equipable] , idesc = "Let's you better focus your weaker eye." @@ -849,29 +860,30 @@ } ring1 = ring { irarity = [(10, 2)] - , iaspects = [AddSpeed $ 1 + d 2, AddMaxHP $ dl 7 - 7 - d 7] + , iaspects = [AddSpeed $ 1 + 1 `d` 2, AddMaxHP $ 1 `dl` 7 - 7 - 1 `d` 7] , ieffects = [ Explode "distortion" -- strong magic , EqpSlot EqpSlotAddSpeed ] } ring2 = ring - { irarity = [(10, 5)] - , iaspects = [AddMaxHP $ 10 + dl 10, AddMaxCalm $ dl 5 - 20 - d 5] + { irarity = [(10, 8)] + , iaspects = [AddMaxHP $ 10 + 1 `dl` 10, AddMaxCalm $ 1 `dl` 5 - 20 - 1 `d` 5] , ieffects = [Explode "blast 20", EqpSlot EqpSlotAddMaxHP] } ring3 = ring - { irarity = [(10, 5)] - , iaspects = [AddMaxCalm $ 29 + dl 10] + { irarity = [(10, 3)] + , iaspects = [AddMaxCalm $ 29 + 1 `dl` 10] , ieffects = [Explode "blast 20", EqpSlot EqpSlotMiscBonus] , idesc = "Cold, solid to the touch, perfectly round, engraved with solemn, strangely comforting, worn out words." } ring4 = ring { irarity = [(3, 3), (10, 5)] - , iaspects = [AddHurtMelee $ d 5 + dl 5 |*| 3, AddMaxHP $ dl 3 - 5 - d 3] + , iaspects = [ AddHurtMelee $ (1 `d` 5 + 1 `dl` 5) * 3 + , AddMaxHP $ 1 `dl` 3 - 5 - 1 `d` 3 ] , ieffects = [Explode "blast 20", EqpSlot EqpSlotAddHurtMelee] } ring5 = ring -- by the time it's found, probably no space in eqp { irarity = [(5, 0), (10, 2)] - , iaspects = [AddShine $ d 2] + , iaspects = [AddShine $ 1 `d` 2] , ieffects = [ Explode "distortion" -- strong magic , EqpSlot EqpSlotLightSource ] , idesc = "A sturdy ring with a large, shining stone." @@ -879,8 +891,8 @@ ring6 = ring { ifreq = [("treasure", 100)] , irarity = [(10, 2)] - , iaspects = [ AddSpeed $ 3 + d 4 - , AddMaxCalm $ - 20 - d 20, AddMaxHP $ - 20 - d 20 ] + , iaspects = [ AddSpeed $ 3 + 1 `d` 4 + , AddMaxCalm $ - 20 - 1 `d` 20, AddMaxHP $ - 20 - 1 `d` 20 ] , ieffects = [ Unique, ELabel "of Rush" -- no explosion, because Durable , EqpSlot EqpSlotAddSpeed ] , ifeature = Durable : ifeature ring @@ -915,8 +927,8 @@ , iweight = 7000 , idamage = toDmg 0 , iaspects = [ AddHurtMelee (-2) - , AddArmorMelee $ 1 + d 2 + dl 2 |*| 5 - , AddArmorRanged $ dl 3 |*| 3 ] + , AddArmorMelee $ (1 + 1 `d` 2 + 1 `dl` 2) * 5 + , AddArmorRanged $ (1 `dl` 3) * 3 ] , ieffects = [EqpSlot EqpSlotAddArmorMelee] , ifeature = [Durable, Identified, Equipable] , idesc = "A stiff jacket formed from leather boiled in bee wax, padded linen and horse hair. Protects from anything that is not too sharp. Smells much better than the rest of your garment." @@ -930,8 +942,8 @@ , iweight = 12000 , idamage = toDmg 0 , iaspects = [ AddHurtMelee (-3) - , AddArmorMelee $ 1 + d 2 + dl 2 |*| 5 - , AddArmorRanged $ 2 + d 2 + dl 3 |*| 3 ] + , AddArmorMelee $ (1 + 1 `d` 2 + 1 `dl` 2) * 5 + , AddArmorRanged $ (2 + 1 `d` 2 + 1 `dl` 3) * 3 ] , ieffects = [EqpSlot EqpSlotAddArmorRanged] , ifeature = [Durable, Identified, Equipable] , idesc = "A long shirt woven from iron rings that are hard to pierce through. Discourages foes from attacking your torso, making it harder for them to hit you." @@ -945,9 +957,9 @@ , irarity = [(5, 9), (10, 9)] , iverbHit = "flap" , iweight = 100 - , idamage = toDmg $ 1 * d 1 - , iaspects = [ AddHurtMelee $ d 2 + dl 7 |*| 3 - , AddArmorRanged $ dl 2 |*| 3 ] + , idamage = toDmg $ 1 `d` 1 + , iaspects = [ AddHurtMelee $ (1 `d` 2 + 1 `dl` 7) * 3 + , AddArmorRanged $ (1 `dl` 2) * 3 ] , ieffects = [EqpSlot EqpSlotAddHurtMelee] , ifeature = [ toVelocity 50 -- flaps and flutters , Durable, Identified, Equipable ] @@ -960,9 +972,9 @@ , iflavour = zipPlain [BrCyan] , irarity = [(1, 9), (10, 3)] , iweight = 300 - , idamage = toDmg $ 2 * d 1 - , iaspects = [ AddArmorMelee $ 2 + dl 2 |*| 5 - , AddArmorRanged $ dl 1 |*| 3 ] + , idamage = toDmg $ 2 `d` 1 + , iaspects = [ AddArmorMelee $ (2 + 1 `dl` 2) * 5 + , AddArmorRanged $ (1 `dl` 1) * 3 ] , ieffects = [EqpSlot EqpSlotAddArmorMelee] , idesc = "Long leather gauntlet covered in overlapping steel plates." } @@ -972,10 +984,10 @@ , iflavour = zipFancy [BrRed] , irarity = [(1, 3), (10, 3)] , iweight = 1000 - , idamage = toDmg $ 3 * d 1 - , iaspects = [ AddHurtMelee $ dl 4 - 6 |*| 3 - , AddArmorMelee $ 2 + d 2 + dl 2 |*| 5 - , AddArmorRanged $ dl 2 |*| 3 ] + , idamage = toDmg $ 3 `d` 1 + , iaspects = [ AddHurtMelee $ (1 `dl` 4 - 6) * 3 + , AddArmorMelee $ (2 + 1 `d` 2 + 1 `dl` 2) * 5 + , AddArmorRanged $ (1 `dl` 2) * 3 ] , ieffects = [Unique, EqpSlot EqpSlotAddArmorMelee] , idesc = "Rigid, steel, jousting handgear. If only you had a lance. And a horse." } @@ -997,10 +1009,10 @@ , irarity = [(4, 6)] , iverbHit = "bash" , iweight = 2000 - , idamage = [(96, 2 * d 1), (3, 4 * d 1), (1, 8 * d 1)] + , idamage = [(96, 2 `d` 1), (3, 4 `d` 1), (1, 8 `d` 1)] , iaspects = [ AddArmorMelee 40 -- not enough to compensate; won't be in eqp , AddHurtMelee (-30) -- too harmful; won't be wielded as weapon - , Timeout $ d 3 + 3 - dl 3 |*| 2 ] + , Timeout $ (1 `d` 3 + 3 - 1 `dl` 3) * 2 ] , ieffects = [ Recharging (PushActor (ThrowMod 200 50)) , EqpSlot EqpSlotAddArmorMelee ] , ifeature = [ toVelocity 50 -- unwieldy to throw @@ -1013,10 +1025,10 @@ , irarity = [(8, 3)] , iflavour = zipPlain [Green] , iweight = 3000 - , idamage = [(96, 4 * d 1), (3, 8 * d 1), (1, 16 * d 1)] + , idamage = [(96, 4 `d` 1), (3, 8 `d` 1), (1, 16 `d` 1)] , iaspects = [ AddArmorMelee 80 -- not enough to compensate; won't be in eqp , AddHurtMelee (-70) -- too harmful; won't be wielded as weapon - , Timeout $ d 6 + 6 - dl 6 |*| 2 ] + , Timeout $ (1 `d` 6 + 6 - 1 `dl` 6) * 2 ] , ieffects = [ Recharging (PushActor (ThrowMod 400 50)) , EqpSlot EqpSlotAddArmorMelee ] , ifeature = [ toVelocity 50 -- unwieldy to throw @@ -1035,9 +1047,9 @@ , irarity = [(1, 50), (3, 1)] , iverbHit = "stab" , iweight = 800 - , idamage = toDmg $ 6 * d 1 - , iaspects = [ AddHurtMelee $ d 3 + dl 3 |*| 3 - , AddArmorMelee $ d 2 |*| 5 ] + , idamage = toDmg $ 6 `d` 1 + , iaspects = [ AddHurtMelee $ (1 `d` 3 + 1 `dl` 3) * 3 + , AddArmorMelee $ (1 `d` 2) * 5 ] , ieffects = [EqpSlot EqpSlotWeapon] , ifeature = [ toVelocity 40 -- ensuring it hits with the tip costs speed , Durable, Identified, Meleeable ] @@ -1056,7 +1068,7 @@ -- If the effect is very powerful and so the timeout has to be significant, -- let's make it really large, for the effect to occur only once in a fight: -- as soon as the item is equipped, or just on the first strike. - , iaspects = iaspects dagger ++ [Timeout $ d 3 + 4 - dl 3 |*| 2] + , iaspects = iaspects dagger ++ [Timeout $ (1 `d` 3 + 4 - 1 `dl` 3) * 2] , ieffects = ieffects dagger ++ [ Unique , Recharging DropBestWeapon, Recharging $ RefillCalm (-3) ] @@ -1071,8 +1083,8 @@ , irarity = [(5, 20), (8, 1)] , iverbHit = "club" , iweight = 1600 - , idamage = [(96, 8 * d 1), (3, 12 * d 1), (1, 16 * d 1)] - , iaspects = [AddHurtMelee $ d 2 + dl 2 |*| 3] + , idamage = [(96, 8 `d` 1), (3, 12 `d` 1), (1, 16 `d` 1)] + , iaspects = [AddHurtMelee $ (1 `d` 2 + 1 `dl` 2) * 3] , ieffects = [EqpSlot EqpSlotWeapon] , ifeature = [ toVelocity 40 -- ensuring it hits with the tip costs speed , Durable, Identified, Meleeable ] @@ -1083,16 +1095,16 @@ { iname = "Concussion Hammer" , ifreq = [("treasure", 20)] , irarity = [(5, 1), (10, 6)] - , idamage = toDmg $ 8 * d 1 - , iaspects = iaspects hammer ++ [Timeout $ d 2 + 3 - dl 2 |*| 2] + , idamage = toDmg $ 8 `d` 1 + , iaspects = iaspects hammer ++ [Timeout $ (1 `d` 2 + 3 - 1 `dl` 2) * 2] , ieffects = ieffects hammer ++ [Unique, Recharging $ Paralyze 10] } hammerSpark = hammer { iname = "Grand Smithhammer" , ifreq = [("treasure", 20)] , irarity = [(5, 1), (10, 6)] - , idamage = toDmg $ 8 * d 1 - , iaspects = iaspects hammer ++ [AddShine 3, Timeout $ d 4 + 4 - dl 4 |*| 2] + , idamage = toDmg $ 12 `d` 1 + , iaspects = iaspects hammer ++ [AddShine 3, Timeout $ (1 `d` 4 + 4 - 1 `dl` 4) * 2] , ieffects = ieffects hammer ++ [Unique, Recharging $ Explode "spark"] } sword = ItemKind @@ -1104,7 +1116,7 @@ , irarity = [(4, 1), (5, 15)] , iverbHit = "slash" , iweight = 2000 - , idamage = toDmg $ 10 * d 1 + , idamage = toDmg $ 10 `d` 1 , iaspects = [] , ieffects = [EqpSlot EqpSlotWeapon] , ifeature = [ toVelocity 40 -- ensuring it hits with the tip costs speed @@ -1116,16 +1128,15 @@ { iname = "Master's Sword" , ifreq = [("treasure", 20)] , irarity = [(5, 1), (10, 6)] - , iaspects = [Timeout $ d 4 + 5 - dl 4 |*| 2] - , ieffects = ieffects sword - ++ [Unique, Recharging Impress, Recharging (DetectActor 5)] - , idesc = "A particularly well-balance blade, lending itself to impressive shows of fencing skill. Master sees enemies reflected on its mirror-like surface." + , iaspects = [Timeout $ (1 `d` 4 + 5 - 1 `dl` 4) * 2] + , ieffects = ieffects sword ++ [Unique, Recharging Impress] + , idesc = "A particularly well-balance blade, lending itself to impressive shows of fencing skill." } swordNullify = sword { iname = "Gutting Sword" , ifreq = [("treasure", 20)] , irarity = [(5, 1), (10, 6)] - , iaspects = [Timeout $ d 4 + 5 - dl 4 |*| 2] + , iaspects = [Timeout $ (1 `d` 4 + 5 - 1 `dl` 4) * 2] , ieffects = ieffects sword ++ [ Unique , Recharging $ DropItem 1 maxBound COrgan @@ -1142,9 +1153,9 @@ , irarity = [(8, 1), (9, 40)] , iverbHit = "impale" , iweight = 3000 - , idamage = [(96, 12 * d 1), (3, 18 * d 1), (1, 24 * d 1)] + , idamage = [(96, 12 `d` 1), (3, 18 `d` 1), (1, 24 `d` 1)] , iaspects = [ AddHurtMelee (-20) -- just benign enough to be used - , AddArmorMelee $ 1 + dl 3 |*| 5 ] + , AddArmorMelee $ (1 + 1 `dl` 3) * 5 ] , ieffects = [EqpSlot EqpSlotWeapon] , ifeature = [ toVelocity 20 -- not balanced , Durable, Identified, Meleeable ] @@ -1155,8 +1166,8 @@ { iname = "Swiss Halberd" , ifreq = [("treasure", 20)] , irarity = [(8, 1), (9, 20)] - , idamage = toDmg $ 12 * d 1 - , iaspects = iaspects halberd ++ [Timeout $ d 5 + 5 - dl 5 |*| 2] + , idamage = toDmg $ 12 `d` 1 + , iaspects = iaspects halberd ++ [Timeout $ (1 `d` 5 + 5 - 1 `dl` 5) * 2] , ieffects = ieffects halberd ++ [Unique, Recharging (PushActor (ThrowMod 400 25))] , idesc = "A versatile polearm, with great reach and leverage. Foes are held at a distance." @@ -1203,8 +1214,8 @@ , iaspects = [AddShine 1, AddSpeed (-1)] -- reflects strongly, distracts; so it glows in the dark, -- is visible on dark floor, but not too tempting to wear - , ieffects = [] - , ifeature = [Precious] -- no @Identified@ and no effects, so never ided + , ieffects = [RefillCalm (-1)] -- minor effect to ensure no id-on-pickup + , ifeature = [Precious] -- no @Identified@, so kind not known , idesc = "Useless, and still worth around 100 gold each. Would gems of thought and pearls of artful design be valued that much in our age of Science and Progress!" , ikit = [] } @@ -1235,7 +1246,7 @@ , iname = "gold piece" , ifreq = [("treasure", 100), ("currency", 100)] , iflavour = zipPlain [BrYellow] - , icount = 10 + d 20 + dl 20 + , icount = 10 + 1 `d` 20 + 1 `dl` 20 , irarity = [(1, 25), (10, 10)] , iverbHit = "tap" , iweight = 31 diff --git a/GameDefinition/Content/ItemKindActor.hs b/GameDefinition/Content/ItemKindActor.hs --- a/GameDefinition/Content/ItemKindActor.hs +++ b/GameDefinition/Content/ItemKindActor.hs @@ -296,14 +296,15 @@ , iverbHit = "thud" , iweight = 80000 , idamage = toDmg 0 - , iaspects = [ AddMaxHP 20, AddMaxCalm 30, AddSpeed 20, AddNocto 2 + , iaspects = [ AddMaxHP 10, AddMaxCalm 30, AddSpeed 20, AddNocto 2 , AddAbility AbAlter (-2) ] -- can't use stairs nor doors , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("hooked claw", COrgan), ("snout", COrgan) - , ("armored skin", COrgan), ("nostril", COrgan) - , ("eye 3", COrgan), ("animal brain", COrgan) ] + , ("armored skin", COrgan), ("armored skin", COrgan) + , ("nostril", COrgan), ("eye 3", COrgan) + , ("animal brain", COrgan) ] } gilaMonster = ItemKind { isymbol = 'g' @@ -516,7 +517,7 @@ geyserSulfur = ItemKind { isymbol = 'g' , iname = "sulfur geyser" - , ifreq = [("animal", 10), ("immobile animal", 100)] + , ifreq = [("animal", 10), ("immobile animal", 120)] , iflavour = zipPlain [BrYellow] -- exception, animal with bright color , icount = 1 , irarity = [(1, 10), (5, 10)] diff --git a/GameDefinition/Content/ItemKindBlast.hs b/GameDefinition/Content/ItemKindBlast.hs --- a/GameDefinition/Content/ItemKindBlast.hs +++ b/GameDefinition/Content/ItemKindBlast.hs @@ -75,13 +75,13 @@ , iname = "firecracker" , ifreq = [(toGroupName $ "firecracker" <+> tshow n, 1)] , iflavour = zipPlain [brightCol !! (n `mod` length brightCol)] - , icount = intToDice (n `div` 6) + d (n `div` 2) + , icount = intToDice (n `div` 6) + 1 `d` (n `div` 2) , irarity = [(1, 1)] , iverbHit = "crack" , iweight = 1 , idamage = toDmg 0 , iaspects = [AddShine $ intToDice $ n `div` 2] - , ieffects = [ RefillCalm (-1) | n >= 5 ] + , ieffects = [ RefillCalm (3 - n) | n >= 5 ] ++ [ DropBestWeapon | n >= 5] ++ [ OnSmash $ Explode $ toGroupName $ "firecracker" <+> tshow (n - 1) @@ -224,7 +224,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [Teleport $ 15 + d 10] + , ieffects = [Teleport $ 15 + 1 `d` 10] , ifeature = [toLinger 10, Fragile, Identified] -- 2 steps, 1 turn , idesc = "" , ikit = [] @@ -343,7 +343,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganActorTurn "strengthened" (3 + d 3)] + , ieffects = [toOrganActorTurn "strengthened" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" , ikit = [] @@ -359,7 +359,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganGameTurn "weakened" (3 + d 3)] + , ieffects = [toOrganGameTurn "weakened" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" , ikit = [] @@ -375,7 +375,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganActorTurn "protected from melee" (3 + d 3)] + , ieffects = [toOrganActorTurn "protected from melee" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" , ikit = [] @@ -391,7 +391,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganActorTurn "protected from ranged" (3 + d 3)] + , ieffects = [toOrganActorTurn "protected from ranged" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" , ikit = [] @@ -407,7 +407,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganGameTurn "defenseless" (3 + d 3)] + , ieffects = [toOrganGameTurn "defenseless" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" , ikit = [] @@ -423,7 +423,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganActorTurn "resolute" (3 + d 3)] + , ieffects = [toOrganActorTurn "resolute" (3 + 1 `d` 3)] -- short enough duration that @calmEnough@ not a big problem , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" @@ -440,7 +440,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganActorTurn "hasted" (3 + d 3)] + , ieffects = [toOrganActorTurn "hasted" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" , ikit = [] @@ -456,7 +456,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganGameTurn "slowed" (3 + d 3)] + , ieffects = [toOrganGameTurn "slowed" (3 + 1 `d` 3)] , ifeature = [toVelocity 5, Fragile, Identified] -- 1 step, 1 turn, mist , idesc = "" , ikit = [] @@ -472,7 +472,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganActorTurn "far-sighted" (3 + d 3)] + , ieffects = [toOrganActorTurn "far-sighted" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" , ikit = [] @@ -488,7 +488,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganActorTurn "blind" (10 + d 10)] + , ieffects = [toOrganActorTurn "blind" (10 + 1 `d` 10)] , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" , ikit = [] @@ -504,7 +504,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganActorTurn "keen-smelling" (3 + d 3)] + , ieffects = [toOrganActorTurn "keen-smelling" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" , ikit = [] @@ -520,7 +520,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganActorTurn "shiny-eyed" (3 + d 3)] + , ieffects = [toOrganActorTurn "shiny-eyed" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" , ikit = [] @@ -539,7 +539,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [toOrganActorTurn "drunk" (3 + d 3)] + , ieffects = [toOrganActorTurn "drunk" (3 + 1 `d` 3)] , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" , ikit = [] @@ -555,7 +555,7 @@ , iweight = 1 , idamage = toDmg 0 , iaspects = [] - , ieffects = [Burn (-1)] + , ieffects = [Burn 1] , ifeature = [toLinger 10, Fragile, Identified] , idesc = "" , ikit = [] diff --git a/GameDefinition/Content/ItemKindEmbed.hs b/GameDefinition/Content/ItemKindEmbed.hs --- a/GameDefinition/Content/ItemKindEmbed.hs +++ b/GameDefinition/Content/ItemKindEmbed.hs @@ -180,7 +180,7 @@ staircaseTrapDown = staircaseTrapUp { ifreq = [("staircase trap down", 1)] , ieffects = [ Temporary "tumble down the stairwell" - , toOrganActorTurn "drunk" (20 + d 5) ] + , toOrganActorTurn "drunk" (20 + 1 `d` 5) ] } doorwayTrap = ItemKind { isymbol = '^' @@ -193,9 +193,9 @@ , iweight = 10000 , idamage = toDmg 0 , iaspects = [] - , ieffects = [OneOf [ RefillCalm (-20) - , toOrganActorTurn "slowed" (20 + d 5) - , toOrganActorTurn "weakened" (20 + d 5) ]] + , ieffects = [OneOf [ toOrganActorTurn "blind" (20 + 1 `d` 5) + , toOrganActorTurn "slowed" (20 + 1 `d` 5) + , toOrganActorTurn "weakened" (20 + 1 `d` 5) ]] , ifeature = [Identified] -- not Durable, springs at most once , idesc = "" , ikit = [] @@ -214,7 +214,7 @@ , ieffects = [ Temporary "enter destructive rage at the sight of obscene pictograms" , RefillCalm (-20) , Recharging $ OneOf - [ toOrganActorTurn "strengthened" (3 + d 3) + [ toOrganActorTurn "strengthened" (3 + 1 `d` 3) , CreateItem CInv "sandstone rock" TimerNone ] ] , ifeature = [Identified, Durable] , idesc = "" @@ -233,8 +233,8 @@ , iaspects = [Timeout 7] , ieffects = [ Temporary "feel refreshed by the subtle fresco" , RefillCalm 2 - , Recharging $ toOrganActorTurn "far-sighted" (3 + d 3) - , Recharging $ toOrganActorTurn "keen-smelling" (3 + d 3) ] + , Recharging $ toOrganActorTurn "far-sighted" (3 + 1 `d` 3) + , Recharging $ toOrganActorTurn "keen-smelling" (3 + 1 `d` 3) ] , ifeature = [Identified, Durable] , idesc = "" , ikit = [] @@ -266,8 +266,8 @@ , iweight = 10000 , idamage = toDmg 0 , iaspects = [] - , ieffects = [ CreateItem CInv "any scroll" TimerNone - , toOrganGameTurn "defenseless" (20 + d 5) + , ieffects = [ CreateItem CGround "any scroll" TimerNone + , toOrganGameTurn "defenseless" (20 + 1 `d` 5) , Explode "PhD defense question" ] , ifeature = [Identified] -- not Durable, springs at most once , idesc = "" diff --git a/GameDefinition/Content/ItemKindOrgan.hs b/GameDefinition/Content/ItemKindOrgan.hs --- a/GameDefinition/Content/ItemKindOrgan.hs +++ b/GameDefinition/Content/ItemKindOrgan.hs @@ -1,4 +1,4 @@ --- | Organ definitions. +-- | Actor organ definitions. module Content.ItemKindOrgan ( organs ) where @@ -37,7 +37,7 @@ , irarity = [(1, 1)] , iverbHit = "punch" , iweight = 2000 - , idamage = toDmg $ 4 * d 1 + , idamage = toDmg $ 4 `d` 1 , iaspects = [] , ieffects = [] , ifeature = [Durable, Identified, Meleeable] @@ -48,7 +48,7 @@ { iname = "foot" , ifreq = [("foot", 50)] , iverbHit = "kick" - , idamage = toDmg $ 4 * d 1 + , idamage = toDmg $ 4 `d` 1 , idesc = "" } @@ -59,8 +59,8 @@ , ifreq = [("hooked claw", 50)] , icount = 2 -- even if more, only the fore claws used for fighting , iverbHit = "hook" - , idamage = toDmg $ 2 * d 1 - , iaspects = [Timeout $ 4 + d 4] + , idamage = toDmg $ 2 `d` 1 + , iaspects = [Timeout $ 4 + 1 `d` 4] , ieffects = [Recharging (toOrganGameTurn "slowed" 2)] , idesc = "" } @@ -68,7 +68,7 @@ { iname = "small claw" , ifreq = [("small claw", 50)] , iverbHit = "slash" - , idamage = toDmg $ 2 * d 1 + , idamage = toDmg $ 2 `d` 1 , idesc = "" } snout = fist @@ -76,7 +76,7 @@ , ifreq = [("snout", 10)] , icount = 1 , iverbHit = "bite" - , idamage = toDmg $ 2 * d 1 + , idamage = toDmg $ 2 `d` 1 , idesc = "" } smallJaw = fist @@ -84,7 +84,7 @@ , ifreq = [("small jaw", 20)] , icount = 1 , iverbHit = "rip" - , idamage = toDmg $ 3 * d 1 + , idamage = toDmg $ 3 `d` 1 , idesc = "" } jaw = fist @@ -92,7 +92,7 @@ , ifreq = [("jaw", 20)] , icount = 1 , iverbHit = "rip" - , idamage = toDmg $ 5 * d 1 + , idamage = toDmg $ 5 `d` 1 , idesc = "" } largeJaw = fist @@ -100,7 +100,7 @@ , ifreq = [("large jaw", 100)] , icount = 1 , iverbHit = "crush" - , idamage = toDmg $ 10 * d 1 + , idamage = toDmg $ 10 `d` 1 , idesc = "" } horn = fist @@ -108,7 +108,7 @@ , ifreq = [("horn", 20)] , icount = 2 , iverbHit = "impale" - , idamage = toDmg $ 6 * d 1 + , idamage = toDmg $ 6 `d` 1 , iaspects = [AddHurtMelee 20] , idesc = "" } @@ -120,40 +120,40 @@ , ifreq = [("tentacle", 50)] , icount = 4 , iverbHit = "slap" - , idamage = toDmg $ 4 * d 1 + , idamage = toDmg $ 4 `d` 1 , idesc = "" } thorn = fist { iname = "thorn" , ifreq = [("thorn", 100)] - , icount = 2 + d 3 + , icount = 2 + 1 `d` 3 , iverbHit = "impale" - , idamage = toDmg $ 1 * d 3 + , idamage = toDmg $ 1 `d` 3 , ifeature = [Identified, Meleeable] -- not Durable , idesc = "" } boilingFissure = fist { iname = "fissure" , ifreq = [("boiling fissure", 100)] - , icount = 5 + d 5 + , icount = 5 + 1 `d` 5 , iverbHit = "hiss at" - , idamage = toDmg $ 1 * d 1 + , idamage = toDmg $ 1 `d` 1 , iaspects = [AddHurtMelee 20] -- decreasing as count decreases - , ieffects = [InsertMove $ 1 * d 3] + , ieffects = [InsertMove $ 1 `d` 3] , ifeature = [Identified, Meleeable] -- not Durable , idesc = "" } arsenicFissure = boilingFissure { iname = "fissure" , ifreq = [("arsenic fissure", 100)] - , icount = 3 + d 3 - , idamage = toDmg $ 2 * d 1 - , ieffects = [toOrganGameTurn "weakened" (2 + d 2)] + , icount = 3 + 1 `d` 3 + , idamage = toDmg $ 2 `d` 1 + , ieffects = [toOrganGameTurn "weakened" (2 + 1 `d` 2)] } sulfurFissure = boilingFissure { iname = "fissure" , ifreq = [("sulfur fissure", 100)] - , icount = 2 + d 2 + , icount = 2 + 1 `d` 2 , idamage = toDmg 0 , ieffects = [RefillHP 5] } @@ -173,8 +173,8 @@ , ifreq = [("sting", 100)] , icount = 1 , iverbHit = "sting" - , idamage = toDmg $ 1 * d 1 - , iaspects = [Timeout $ 1 + d 5, AddHurtMelee 40] + , idamage = toDmg $ 1 `d` 1 + , iaspects = [Timeout $ 1 + 1 `d` 5, AddHurtMelee 40] , ieffects = [Recharging (Paralyze 4)] , idesc = "Painful, debilitating and harmful." } @@ -183,9 +183,9 @@ , ifreq = [("venom tooth", 100)] , icount = 2 , iverbHit = "bite" - , idamage = toDmg $ 2 * d 1 - , iaspects = [Timeout $ 5 + d 3] - , ieffects = [Recharging (toOrganGameTurn "slowed" (3 + d 3))] + , idamage = toDmg $ 2 `d` 1 + , iaspects = [Timeout $ 5 + 1 `d` 3] + , ieffects = [Recharging (toOrganGameTurn "slowed" (3 + 1 `d` 3))] , idesc = "" } venomFang = fist @@ -193,8 +193,8 @@ , ifreq = [("venom fang", 100)] , icount = 2 , iverbHit = "bite" - , idamage = toDmg $ 2 * d 1 - , iaspects = [Timeout $ 7 + d 5] + , idamage = toDmg $ 2 `d` 1 + , iaspects = [Timeout $ 7 + 1 `d` 5] , ieffects = [Recharging (toOrganNone "poisoned")] , idesc = "" } @@ -203,9 +203,9 @@ , ifreq = [("screeching beak", 100)] , icount = 1 , iverbHit = "peck" - , idamage = toDmg $ 2 * d 1 - , iaspects = [Timeout $ 5 + d 5] - , ieffects = [Recharging $ Summon "scavenger" $ 1 + dl 2] + , idamage = toDmg $ 2 `d` 1 + , iaspects = [Timeout $ 5 + 1 `d` 5] + , ieffects = [Recharging $ Summon "scavenger" $ 1 + 1 `dl` 2] , idesc = "" } largeTail = fist @@ -213,8 +213,8 @@ , ifreq = [("large tail", 50)] , icount = 1 , iverbHit = "knock" - , idamage = toDmg $ 6 * d 1 - , iaspects = [Timeout $ 1 + d 3, AddHurtMelee 20] + , idamage = toDmg $ 6 `d` 1 + , iaspects = [Timeout $ 1 + 1 `d` 3, AddHurtMelee 20] , ieffects = [Recharging (PushActor (ThrowMod 400 25))] , idesc = "" } @@ -290,7 +290,7 @@ { iname = "insect mortality" , ifreq = [("insect mortality", 100)] , iverbHit = "age" - , iaspects = [Timeout $ 40 + d 10] + , iaspects = [Timeout $ 40 + 1 `d` 10] , ieffects = [Periodic, Recharging (RefillHP (-1))] , idesc = "" } @@ -331,7 +331,7 @@ { iname = "scent gland" , ifreq = [("scent gland", 100)] , iverbHit = "spray at" - , iaspects = [Timeout $ 10 + d 2 |*| 5 ] + , iaspects = [Timeout $ (10 + 1 `d` 2) * 5 ] , ieffects = [ Periodic, Recharging (Explode "distressing odor") , Recharging ApplyPerfume ] , idesc = "" @@ -341,7 +341,7 @@ , ifreq = [("boiling vent", 100)] , iflavour = zipPlain [Blue] , iverbHit = "menace" - , iaspects = [Timeout $ 2 + d 2 |*| 5] + , iaspects = [Timeout $ (2 + 1 `d` 2) * 5] , ieffects = [Periodic , Recharging (Explode "boiling water") , Recharging (RefillHP 2) ] @@ -352,7 +352,7 @@ , ifreq = [("arsenic vent", 100)] , iflavour = zipPlain [Cyan] , iverbHit = "menace" - , iaspects = [Timeout $ 2 + d 2 |*| 5] + , iaspects = [Timeout $ (2 + 1 `d` 2) * 5] , ieffects = [ Periodic , Recharging (Explode "sparse shower") , Recharging (RefillHP 2) ] @@ -363,7 +363,7 @@ , ifreq = [("sulfur vent", 100)] , iflavour = zipPlain [BrYellow] , iverbHit = "menace" - , iaspects = [Timeout $ 2 + d 2 |*| 5] + , iaspects = [Timeout $ (2 + 1 `d` 2) * 5] , ieffects = [ Periodic , Recharging (Explode "dense shower") , Recharging (RefillHP 2) ] @@ -387,7 +387,7 @@ , ifreq = [("tooth", 20)] , icount = 3 , iverbHit = "nail" - , idamage = toDmg $ 2 * d 1 + , idamage = toDmg $ 2 `d` 1 , idesc = "" } lash = fist @@ -395,7 +395,7 @@ , ifreq = [("lash", 100)] , icount = 1 , iverbHit = "lash" - , idamage = toDmg $ 3 * d 1 + , idamage = toDmg $ 3 `d` 1 , idesc = "" } noseTip = fist @@ -403,7 +403,7 @@ , ifreq = [("nose tip", 50)] , icount = 1 , iverbHit = "poke" - , idamage = toDmg $ 2 * d 1 + , idamage = toDmg $ 2 `d` 1 , idesc = "" } lip = fist @@ -411,9 +411,9 @@ , ifreq = [("lip", 10)] , icount = 1 , iverbHit = "lap" - , idamage = toDmg $ 1 * d 1 - , iaspects = [Timeout $ 3 + d 3] - , ieffects = [Recharging (toOrganGameTurn "weakened" (2 + d 2))] + , idamage = toDmg $ 1 `d` 1 + , iaspects = [Timeout $ 3 + 1 `d` 3] + , ieffects = [Recharging (toOrganGameTurn "weakened" (2 + 1 `d` 2))] , idesc = "" } torsionRight = fist @@ -421,9 +421,9 @@ , ifreq = [("right torsion", 100)] , icount = 1 , iverbHit = "twist" - , idamage = toDmg $ 13 * d 1 - , iaspects = [Timeout $ 5 + d 5, AddHurtMelee 20] - , ieffects = [Recharging (toOrganGameTurn "slowed" (3 + d 3))] + , idamage = toDmg $ 13 `d` 1 + , iaspects = [Timeout $ 5 + 1 `d` 5, AddHurtMelee 20] + , ieffects = [Recharging (toOrganGameTurn "slowed" (3 + 1 `d` 3))] , idesc = "" } torsionLeft = fist @@ -431,9 +431,9 @@ , ifreq = [("left torsion", 100)] , icount = 1 , iverbHit = "twist" - , idamage = toDmg $ 13 * d 1 - , iaspects = [Timeout $ 5 + d 5, AddHurtMelee 20] - , ieffects = [Recharging (toOrganGameTurn "weakened" (3 + d 3))] + , idamage = toDmg $ 13 `d` 1 + , iaspects = [Timeout $ 5 + 1 `d` 5, AddHurtMelee 20] + , ieffects = [Recharging (toOrganGameTurn "weakened" (3 + 1 `d` 3))] , idesc = "" } pupil = fist @@ -441,8 +441,8 @@ , ifreq = [("pupil", 100)] , icount = 1 , iverbHit = "gaze at" - , idamage = toDmg $ 1 * d 1 - , iaspects = [AddSight 12, Timeout $ 5 + d 5] + , idamage = toDmg $ 1 `d` 1 + , iaspects = [AddSight 12, Timeout $ 5 + 1 `d` 5] , ieffects = [ Recharging (DropItem 1 maxBound COrgan "temporary condition") , Recharging $ RefillCalm (-10) ] diff --git a/GameDefinition/Content/ItemKindTemporary.hs b/GameDefinition/Content/ItemKindTemporary.hs --- a/GameDefinition/Content/ItemKindTemporary.hs +++ b/GameDefinition/Content/ItemKindTemporary.hs @@ -66,22 +66,22 @@ ] tmpRegenerating = let tmp = tmpAs "regenerating" [] - in tmp { icount = 4 + d 2 + in tmp { icount = 4 + 1 `d` 2 , ieffects = Recharging (RefillHP 1) : ieffects tmp } tmpPoisoned = let tmp = tmpAs "poisoned" [] - in tmp { icount = 4 + d 2 + in tmp { icount = 4 + 1 `d` 2 , ieffects = Recharging (RefillHP (-1)) : ieffects tmp } tmpSlow10Resistant = let tmp = tmpAs "slow resistant" [] - in tmp { icount = 8 + d 4 + in tmp { icount = 8 + 1 `d` 4 , ieffects = Recharging (DropItem 1 1 COrgan "slowed") : ieffects tmp } tmpPoisonResistant = let tmp = tmpAs "poison resistant" [] - in tmp { icount = 8 + d 4 + in tmp { icount = 8 + 1 `d` 4 , ieffects = Recharging (DropItem 1 maxBound COrgan "poisoned") : ieffects tmp } diff --git a/GameDefinition/Content/ModeKind.hs b/GameDefinition/Content/ModeKind.hs --- a/GameDefinition/Content/ModeKind.hs +++ b/GameDefinition/Content/ModeKind.hs @@ -22,9 +22,9 @@ , validateSingle = validateSingleModeKind , validateAll = validateAllModeKind , content = contentFromList - [raid, brawl, shootout, escape, zoo, ambush, exploration, explorationSurvival, safari, safariSurvival, battle, battleSurvival, defense, screensaverRaid, screensaverBrawl, screensaverShootout, screensaverEscape, screensaverZoo, screensaverAmbush, screensaverExploration, screensaverSafari] + [raid, brawl, shootout, escape, zoo, ambush, crawl, crawlSurvival, safari, safariSurvival, battle, battleSurvival, defense, screensaverRaid, screensaverBrawl, screensaverShootout, screensaverEscape, screensaverZoo, screensaverAmbush, screensaverCrawl, screensaverSafari] } -raid, brawl, shootout, escape, zoo, ambush, exploration, explorationSurvival, safari, safariSurvival, battle, battleSurvival, defense, screensaverRaid, screensaverBrawl, screensaverShootout, screensaverEscape, screensaverZoo, screensaverAmbush, screensaverExploration, screensaverSafari :: ModeKind +raid, brawl, shootout, escape, zoo, ambush, crawl, crawlSurvival, safari, safariSurvival, battle, battleSurvival, defense, screensaverRaid, screensaverBrawl, screensaverShootout, screensaverEscape, screensaverZoo, screensaverAmbush, screensaverCrawl, screensaverSafari :: ModeKind -- What other symmetric (two only-one-moves factions) and asymmetric vs crowd -- scenarios make sense (e.g., are good for a tutorial or for standalone @@ -109,13 +109,13 @@ , mdesc = "Prevent hijacking of your ideas at all cost! Be stealthy, be aggressive. Fast execution is what makes or breaks a creative team." } -exploration = ModeKind +crawl = ModeKind { msymbol = 'c' , mname = "crawl (long)" - , mfreq = [("crawl", 1), ("exploration", 1), ("campaign scenario", 1)] - , mroster = rosterExploration - , mcaves = cavesExploration - , mdesc = "Enjoy the peaceful seclusion of these cold austere tunnels, but don't let wanton curiosity, greed and the ever-creeping abstraction madness keep you down there for too long." + , mfreq = [("crawl", 1), ("campaign scenario", 1)] + , mroster = rosterCrawl + , mcaves = cavesCrawl + , mdesc = "Enjoy the peaceful seclusion of these cold austere tunnels, but don't let wanton curiosity, greed and the ever-creeping abstraction madness keep you down there for too long. If find survivors (whole or perturbed or segmented) of the past scientific missions, exercise extreme caution and engage or ignore at your discretion." } safari = ModeKind -- easter egg available only via screensaver @@ -124,17 +124,17 @@ , mfreq = [("safari", 1)] , mroster = rosterSafari , mcaves = cavesSafari - , mdesc = "\"In this simulation you'll discover the joys of hunting the most exquisite of Earth's flora and fauna, both animal and semi-intelligent. Exit at the bottommost level.\" This is a VR recording recovered from a monster nest debris." + , mdesc = "\"In this enactment you'll discover the joys of hunting the most exquisite of Earth's flora and fauna, both animal and semi-intelligent. Exit at the bottommost level.\" This is a drama script recovered from a monster nest debris." } -- * Testing modes -explorationSurvival = ModeKind +crawlSurvival = ModeKind { msymbol = 'd' , mname = "crawl survival" , mfreq = [("crawl survival", 1)] - , mroster = rosterExplorationSurvival - , mcaves = cavesExploration + , mroster = rosterCrawlSurvival + , mcaves = cavesCrawl , mdesc = "Lure the human intruders deeper and deeper." } @@ -144,7 +144,7 @@ , mfreq = [("safari survival", 1)] , mroster = rosterSafariSurvival , mcaves = cavesSafari - , mdesc = "In this simulation you'll discover the joys of being hunted among the most exquisite of Earth's flora and fauna, both animal and semi-intelligent." + , mdesc = "In this enactment you'll discover the joys of being hunted among the most exquisite of Earth's flora and fauna, both animal and semi-intelligent." } battle = ModeKind @@ -170,7 +170,7 @@ , mname = "defense" , mfreq = [("defense", 1)] , mroster = rosterDefense - , mcaves = cavesExploration + , mcaves = cavesCrawl , mdesc = "Don't let human interlopers defile your abstract secrets and flee unpunished!" } @@ -219,10 +219,10 @@ , mroster = screensave (AutoLeader False False) rosterAmbush } -screensaverExploration = exploration +screensaverCrawl = crawl { mname = "auto-crawl (long)" , mfreq = [("no confirms", 1)] - , mroster = screensave (AutoLeader False False) rosterExploration + , mroster = screensave (AutoLeader False False) rosterCrawl } screensaverSafari = safari @@ -232,7 +232,7 @@ screensave (AutoLeader False True) rosterSafari } -rosterRaid, rosterBrawl, rosterShootout, rosterEscape, rosterZoo, rosterAmbush, rosterExploration, rosterExplorationSurvival, rosterSafari, rosterSafariSurvival, rosterBattle, rosterBattleSurvival, rosterDefense :: Roster +rosterRaid, rosterBrawl, rosterShootout, rosterEscape, rosterZoo, rosterAmbush, rosterCrawl, rosterCrawlSurvival, rosterSafari, rosterSafariSurvival, rosterBattle, rosterBattleSurvival, rosterDefense :: Roster rosterRaid = Roster { rosterList = [ ( playerHero {fhiCondPoly = hiRaid} @@ -319,21 +319,21 @@ , ("Indigo Researcher", "Horror Den") ] , rosterAlly = [] } -rosterExploration = Roster +rosterCrawl = Roster { rosterList = [ ( playerHero , [(-1, 3, "hero")] ) , ( playerMonster , [(-4, 1, "scout monster"), (-4, 3, "monster")] ) , ( playerAnimal , -- Fun from the start to avoid empty initial level: - [ (-1, 1 + d 2, "animal") + [ (-1, 1 + 1 `d` 2, "animal") -- Huge battle at the end: , (-10, 100, "mobile animal") ] ) ] , rosterEnemy = [ ("Explorer", "Monster Hive") , ("Explorer", "Animal Kingdom") ] , rosterAlly = [("Monster Hive", "Animal Kingdom")] } -rosterExplorationSurvival = rosterExploration +rosterCrawlSurvival = rosterCrawl { rosterList = [ ( playerHero { fleaderMode = LeaderAI $ AutoLeader True False , fhasUI = False } @@ -342,7 +342,7 @@ , [(-4, 1, "scout monster"), (-4, 3, "monster")] ) , ( playerAnimal {fhasUI = True} , -- Fun from the start to avoid empty initial level: - [ (-1, 1 + d 2, "animal") + [ (-1, 1 + 1 `d` 2, "animal") -- Huge battle at the end: , (-10, 100, "mobile animal") ] ) ] } @@ -407,16 +407,16 @@ , fhasUI = True } , [(-5, 30, "mobile animal")] ) ] } -rosterDefense = rosterExploration +rosterDefense = rosterCrawl { rosterList = [ ( playerAntiHero , [(-1, 3, "hero")] ) , ( playerAntiMonster , [(-4, 1, "scout monster"), (-4, 3, "monster")] ) , ( playerAnimal - , [ (-1, 1 + d 2, "animal") + , [ (-1, 1 + 1 `d` 2, "animal") , (-10, 100, "mobile animal") ] ) ] } -cavesRaid, cavesBrawl, cavesShootout, cavesEscape, cavesZoo, cavesAmbush, cavesExploration, cavesSafari, cavesBattle :: Caves +cavesRaid, cavesBrawl, cavesShootout, cavesEscape, cavesZoo, cavesAmbush, cavesCrawl, cavesSafari, cavesBattle :: Caves cavesRaid = IM.fromList [(-2, "caveRaid")] @@ -430,7 +430,7 @@ cavesAmbush = IM.fromList [(-9, "caveAmbush")] -cavesExploration = IM.fromList $ +cavesCrawl = IM.fromList $ [ (-1, "outermost") , (-2, "shallow random 2") , (-3, "caveEmpty") ] diff --git a/GameDefinition/Content/PlaceKind.hs b/GameDefinition/Content/PlaceKind.hs --- a/GameDefinition/Content/PlaceKind.hs +++ b/GameDefinition/Content/PlaceKind.hs @@ -32,8 +32,7 @@ rect = PlaceKind -- Valid for any nonempty area, hence low frequency. { psymbol = 'r' , pname = "room" - , pfreq = [ ("rogue", 100), ("arena", 40), ("laboratory", 40) - , ("shootout", 8), ("zoo", 7) ] + , pfreq = [("rogue", 100), ("arena", 40), ("laboratory", 40), ("zoo", 9)] , prarity = [(1, 10), (10, 8)] , pcover = CStretch , pfence = FNone @@ -59,7 +58,7 @@ glasshouse = PlaceKind { psymbol = 'g' , pname = "glasshouse" - , pfreq = [("arena", 40), ("zoo", 12)] + , pfreq = [("arena", 40), ("shootout", 8), ("zoo", 9)] , prarity = [(1, 10), (10, 8)] , pcover = CStretch , pfence = FNone diff --git a/GameDefinition/Content/TileKind.hs b/GameDefinition/Content/TileKind.hs --- a/GameDefinition/Content/TileKind.hs +++ b/GameDefinition/Content/TileKind.hs @@ -115,7 +115,8 @@ , talter = 2 , tfeature = [ RevealAs "trapped vertical door Lit" , ObscureAs "obscured vertical wall Lit" - , Indistinct ] + , Indistinct + ] } wallObscured = TileKind { tsymbol = '|' @@ -137,7 +138,8 @@ , tcolor2 = defFG , talter = 100 , tfeature = [ BuildAs "suspect horizontal wall Lit" - , Indistinct ] + , Indistinct + ] } wallSuspectH = TileKind -- only on client { tsymbol = '-' @@ -148,7 +150,8 @@ , talter = 2 , tfeature = [ RevealAs "trapped horizontal door Lit" , ObscureAs "obscured horizontal wall Lit" - , Indistinct ] + , Indistinct + ] } wallObscuredDefacedH = TileKind { tsymbol = '-' @@ -214,11 +217,12 @@ , tcolor = BrCyan , tcolor2 = Cyan , talter = 5 - , tfeature = [ Embed "signboard", Indistinct - , ConsideredByAI -- changes after use, so safe for AI - , RevealAs "signboard" ] -- to display as hidden + , tfeature = [ ConsideredByAI -- changes after use, so safe for AI + , RevealAs "signboard" -- to display as hidden + , Indistinct + ] } -signboardRead = TileKind -- after first use revealed to be this one +signboardRead = TileKind { tsymbol = 'O' , tname = "signboard" , tfreq = [("signboard", 1), ("zooSet", 2)] diff --git a/GameDefinition/Main.hs b/GameDefinition/Main.hs --- a/GameDefinition/Main.hs +++ b/GameDefinition/Main.hs @@ -8,24 +8,34 @@ import Game.LambdaHack.Common.Prelude -import Control.Concurrent.Async +import Control.Concurrent.Async import qualified Control.Exception as Ex -import System.Environment (getArgs) -import System.Exit +import qualified GHC.IO.Handle as GHC.IO.Handle +import qualified Options.Applicative as OA +import System.Exit +import qualified System.IO as SIO +import Game.LambdaHack.Server (serverOptionsPI) import TieKnot --- | Tie the LambdaHack engine client, server and frontend code --- with the game-specific content definitions, and run the game. +-- | Parse commandline options, tie the engine, content and clients knot, +-- run the game and handle exit. main :: IO () main = do - args <- getArgs + -- For the case when the game is started not on a console. + isTerminal <- SIO.hIsTerminalDevice SIO.stdout + unless isTerminal $ do + fstdout <- SIO.openFile "stdout.txt" SIO.WriteMode + fstderr <- SIO.openFile "stderr.txt" SIO.WriteMode + GHC.IO.Handle.hDuplicateTo fstdout SIO.stdout + GHC.IO.Handle.hDuplicateTo fstderr SIO.stderr + serverOptions <- OA.execParser serverOptionsPI -- Avoid the bound thread that would slow down the communication. - a <- async $ tieKnot args + a <- async $ tieKnot serverOptions ex <- waitCatch a case ex of Right () -> return () Left e -> case Ex.fromException e of Just ExitSuccess -> - exitSuccess -- we are in the main thread, so it really exits + exitSuccess -- we are in the main thread, so here it really exits _ -> Ex.throwIO e diff --git a/GameDefinition/PLAYING.md b/GameDefinition/PLAYING.md --- a/GameDefinition/PLAYING.md +++ b/GameDefinition/PLAYING.md @@ -270,7 +270,8 @@ The stress of combat drains Calm, gradually limiting the use of items and, if Calm reaches zero and the actor is sufficiently impressed by his foes, making him defect and surrender to their domination. -Whenever the monster's or hero's hit points reach zero, the combatant dies. +Whenever the monster's or hero's hit points reach zero, +the combatant is incapacitated and promptly dies. When the last hero dies or is dominated, the scenario ends in defeat. diff --git a/GameDefinition/TieKnot.hs b/GameDefinition/TieKnot.hs --- a/GameDefinition/TieKnot.hs +++ b/GameDefinition/TieKnot.hs @@ -1,4 +1,4 @@ --- | Here the knot of engine code pieces and the game-specific +-- | Here the knot of engine code pieces, frontend and the game-specific -- content definitions is tied, resulting in an executable game. module TieKnot ( tieKnot @@ -10,12 +10,12 @@ import qualified System.Random as R -import Game.LambdaHack.Common.ContentDef +import Game.LambdaHack.Common.ContentDef import qualified Game.LambdaHack.Common.Kind as Kind import qualified Game.LambdaHack.Common.Tile as Tile -import Game.LambdaHack.Content.ItemKind -import Game.LambdaHack.SampleImplementation.SampleMonadServer (executorSer) -import Game.LambdaHack.Server +import qualified Game.LambdaHack.Content.ItemKind as IK +import Game.LambdaHack.SampleImplementation.SampleMonadServer (executorSer) +import Game.LambdaHack.Server import qualified Client.UI.Content.KeyKind as Content.KeyKind import qualified Content.CaveKind @@ -28,47 +28,29 @@ -- | Tie the LambdaHack engine client, server and frontend code -- with the game-specific content definitions, and run the game. -- --- The action monad types to be used are determined by the 'executorSer' --- and 'executorCli' calls. If other functions are used in their place --- the types are different and so the whole pattern of computation --- is different. Which of the frontends is run inside the UI client +-- The custom monad types to be used are determined by the 'executorSer' +-- call, which in turn calls 'executorCli'. If other functions are used +-- in their place- the types are different and so the whole pattern +-- of computation differs. Which of the frontends is run inside the UI client -- depends on the flags supplied when compiling the engine library. -tieKnot :: [String] -> IO () -tieKnot args = do - -- Options for the next game taken from the commandline. - let sdebug@DebugModeSer{sallClear, sboostRandomItem, sdungeonRng} = - debugArgs args +-- Similarly for the choice of native vs JS builds. +tieKnot :: ServerOptions -> IO () +tieKnot options@ServerOptions{sallClear, sboostRandomItem, sdungeonRng} = do -- This setup ensures the boosting option doesn't affect generating initial -- RNG for dungeon, etc., and also, that setting dungeon RNG on commandline -- equal to what was generated last time, ensures the same item boost. initialGen <- maybe R.getStdGen return sdungeonRng - let sdebugNxt = sdebug {sdungeonRng = Just initialGen} + let soptionsNxt = options {sdungeonRng = Just initialGen} + cotile = Kind.createOps Content.TileKind.cdefs + boostedItems = IK.boostItemKindList initialGen Content.ItemKind.items + coitem = Kind.createOps $ + if sboostRandomItem + then Content.ItemKind.cdefs + {content = contentFromList + $ boostedItems ++ Content.ItemKind.otherItemContent} + else Content.ItemKind.cdefs -- Common content operations, created from content definitions. -- Evaluated fully to discover errors ASAP and to free memory. - cotile = Kind.createOps Content.TileKind.cdefs - boostItem :: ItemKind -> ItemKind - boostItem i = - let mainlineLabel (label, _) = label `elem` ["useful", "treasure"] - in if any mainlineLabel (ifreq i) - then i { ifreq = ("useful", 10000) - : filter (not . mainlineLabel) (ifreq i) - , ieffects = delete Unique $ ieffects i - } - else i - boostList :: [ItemKind] -> [ItemKind] - boostList l | not sboostRandomItem = l - boostList [] = [] - boostList l = - let (r, _) = R.randomR (0, length l - 1) initialGen - in case splitAt r l of - (pre, i : post) -> pre ++ boostItem i : post - _ -> error $ "" `showFailure` l - boostedItems = boostList Content.ItemKind.items - cdefsItem = - Content.ItemKind.cdefs - {content = contentFromList - $ boostedItems ++ Content.ItemKind.otherItemContent} - coitem = Kind.createOps cdefsItem !cops = Kind.COps { cocave = Kind.createOps Content.CaveKind.cdefs , coitem @@ -83,4 +65,4 @@ !copsClient = Content.KeyKind.standardKeys -- Wire together game content, the main loops of game clients -- and the game server loop. - executorSer cops copsClient sdebugNxt + executorSer cops copsClient soptionsNxt diff --git a/LambdaHack.cabal b/LambdaHack.cabal --- a/LambdaHack.cabal +++ b/LambdaHack.cabal @@ -5,7 +5,7 @@ -- PVP summary:+-+------- breaking API changes -- | | +----- minor or non-breaking API additions -- | | | +--- code changes with no API change -version: 0.6.2.0 +version: 0.7.0.0 synopsis: A game engine library for roguelike dungeon crawlers description: LambdaHack is a Haskell game engine library for roguelike games of arbitrary theme, size and complexity, @@ -60,7 +60,7 @@ bug-reports: http://github.com/LambdaHack/LambdaHack/issues license: BSD3 license-file: LICENSE -tested-with: GHC >= 8.0 && <= 8.2 +tested-with: GHC==8.0.2, GHC==8.2.1, GHC==8.2.2 data-files: GameDefinition/config.ui.default, GameDefinition/fonts/16x16x.fon, GameDefinition/fonts/8x8xb.fon, @@ -124,7 +124,6 @@ exposed-modules: Game.LambdaHack.Atomic Game.LambdaHack.Atomic.CmdAtomic Game.LambdaHack.Atomic.HandleAtomicWrite - Game.LambdaHack.Atomic.MonadAtomic Game.LambdaHack.Atomic.MonadStateWrite Game.LambdaHack.Atomic.PosAtomicRead Game.LambdaHack.Client @@ -136,17 +135,19 @@ Game.LambdaHack.Client.AI.Strategy Game.LambdaHack.Client.Bfs Game.LambdaHack.Client.BfsM + Game.LambdaHack.Client.ClientOptions Game.LambdaHack.Client.CommonM Game.LambdaHack.Client.HandleAtomicM Game.LambdaHack.Client.HandleResponseM Game.LambdaHack.Client.LoopM Game.LambdaHack.Client.MonadClient Game.LambdaHack.Client.Preferences + Game.LambdaHack.Client.Request + Game.LambdaHack.Client.Response Game.LambdaHack.Client.State Game.LambdaHack.Client.UI Game.LambdaHack.Client.UI.ActorUI Game.LambdaHack.Client.UI.Animation - Game.LambdaHack.Client.UI.Config Game.LambdaHack.Client.UI.Content.KeyKind Game.LambdaHack.Client.UI.DrawM Game.LambdaHack.Client.UI.DisplayAtomicM @@ -171,15 +172,14 @@ Game.LambdaHack.Client.UI.Msg Game.LambdaHack.Client.UI.MsgM Game.LambdaHack.Client.UI.Overlay - Game.LambdaHack.Client.UI.OverlayM Game.LambdaHack.Client.UI.RunM Game.LambdaHack.Client.UI.SessionUI Game.LambdaHack.Client.UI.Slideshow Game.LambdaHack.Client.UI.SlideshowM + Game.LambdaHack.Client.UI.UIOptions Game.LambdaHack.Common.Ability Game.LambdaHack.Common.Actor Game.LambdaHack.Common.ActorState - Game.LambdaHack.Common.ClientOptions Game.LambdaHack.Common.Color Game.LambdaHack.Common.ContentDef Game.LambdaHack.Common.Dice @@ -200,10 +200,9 @@ Game.LambdaHack.Common.Point Game.LambdaHack.Common.Prelude Game.LambdaHack.Common.Random + Game.LambdaHack.Common.ReqFailure Game.LambdaHack.Common.RingBuffer Game.LambdaHack.Common.Save - Game.LambdaHack.Common.Request - Game.LambdaHack.Common.Response Game.LambdaHack.Common.State Game.LambdaHack.Common.Thread Game.LambdaHack.Common.Tile @@ -239,6 +238,7 @@ Game.LambdaHack.Server.MonadServer Game.LambdaHack.Server.PeriodicM Game.LambdaHack.Server.ProtocolM + Game.LambdaHack.Server.ServerOptions Game.LambdaHack.Server.StartM Game.LambdaHack.Server.State @@ -260,10 +260,11 @@ hsini >= 0.2, keys >= 3, miniutter >= 0.4.5.0, - time >= 1.4, + optparse-applicative >= 0.13, pretty-show >= 1.6, random >= 1.1, stm >= 2.4, + time >= 1.4, text >= 0.11.2.3, transformers >= 0.4, unordered-containers >= 0.2.3, @@ -273,7 +274,7 @@ default-language: Haskell2010 default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf, - StrictData, CPP + LambdaCase, StrictData, CPP other-extensions: TemplateHaskell, MultiParamTypeClasses, RankNTypes, TypeFamilies, FlexibleContexts, FlexibleInstances, DeriveFunctor, FunctionalDependencies, @@ -281,44 +282,37 @@ DeriveFoldable, DeriveTraversable, ExistentialQuantification, GADTs, StandaloneDeriving, DataKinds, KindSignatures, DeriveGeneric - ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities + ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities -Wredundant-constraints ghc-options: -Wall-missed-specialisations - ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively + ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively -fsimpl-tick-factor=200 - if impl(ghcjs) { - other-modules: Game.LambdaHack.Client.UI.Frontend.Dom + if impl(ghcjs) || flag(jsaddle) { + exposed-modules: Game.LambdaHack.Client.UI.Frontend.Dom build-depends: ghcjs-dom >= 0.9.1.1 - cpp-options: -DUSE_BROWSER -DUSE_JSFILE + cpp-options: -DUSE_BROWSER } else { if flag(vty) { - other-modules: Game.LambdaHack.Client.UI.Frontend.Vty + exposed-modules: Game.LambdaHack.Client.UI.Frontend.Vty build-depends: vty >= 5 cpp-options: -DUSE_VTY } else { if flag(curses) { - other-modules: Game.LambdaHack.Client.UI.Frontend.Curses + exposed-modules: Game.LambdaHack.Client.UI.Frontend.Curses build-depends: hscurses >= 1.4.1 cpp-options: -DUSE_CURSES } else { if flag(gtk) { - other-modules: Game.LambdaHack.Client.UI.Frontend.Gtk + exposed-modules: Game.LambdaHack.Client.UI.Frontend.Gtk build-depends: gtk3 >= 0.12.1 cpp-options: -DUSE_GTK - } else { if flag(sdl) { - other-modules: Game.LambdaHack.Client.UI.Frontend.Sdl - build-depends: sdl2 >= 2, sdl2-ttf >= 2 - cpp-options: -DUSE_SDL - } else { if flag(jsaddle) { - other-modules: Game.LambdaHack.Client.UI.Frontend.Dom - build-depends: ghcjs-dom >= 0.9.1.1 - cpp-options: -DUSE_BROWSER } else { - other-modules: Game.LambdaHack.Client.UI.Frontend.Sdl + exposed-modules: Game.LambdaHack.Client.UI.Frontend.Sdl build-depends: sdl2 >= 2, sdl2-ttf >= 2 cpp-options: -DUSE_SDL - } } } } } } + } } } } if impl(ghcjs) { - other-modules: Game.LambdaHack.Common.JSFile + exposed-modules: Game.LambdaHack.Common.JSFile + cpp-options: -DUSE_JSFILE } else { - other-modules: Game.LambdaHack.Common.HSFile + exposed-modules: Game.LambdaHack.Common.HSFile build-depends: zlib >= 0.5.3.1 } @@ -365,11 +359,12 @@ hsini >= 0.2, keys >= 3, miniutter >= 0.4.5.0, - time >= 1.4, + optparse-applicative >= 0.13, pretty-show >= 1.6, random >= 1.1, stm >= 2.4, text >= 0.11.2.3, + time >= 1.4, transformers >= 0.4, unordered-containers >= 0.2.3, vector >= 0.11, @@ -378,9 +373,9 @@ default-language: Haskell2010 default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf, - StrictData + LambdaCase, StrictData other-extensions: TemplateHaskell - ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities + ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities -Wredundant-constraints ghc-options: -Wall-missed-specialisations ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively ghc-options: -threaded -rtsopts @@ -438,11 +433,12 @@ hsini >= 0.2, keys >= 3, miniutter >= 0.4.5.0, - time >= 1.4, + optparse-applicative >= 0.13, pretty-show >= 1.6, random >= 1.1, stm >= 2.4, text >= 0.11.2.3, + time >= 1.4, transformers >= 0.4, unordered-containers >= 0.2.3, vector >= 0.11, @@ -451,9 +447,9 @@ default-language: Haskell2010 default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings BangPatterns, RecordWildCards, NamedFieldPuns, MultiWayIf, - StrictData + LambdaCase, StrictData other-extensions: TemplateHaskell - ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities + ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities -Wredundant-constraints ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively ghc-options: -threaded -rtsopts diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -34,8 +34,8 @@ frontendAmbush: dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode ambush -frontendExploration: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 1 --dumpInitRngs --automateAll --gameMode exploration +frontendCrawl: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 1 --dumpInitRngs --automateAll --gameMode crawl frontendSafari: dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix test --newGame 2 --dumpInitRngs --automateAll --gameMode safari @@ -54,7 +54,7 @@ benchMemoryAnim: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 1 --maxFps 100000 --benchmark --stopAfterFrames 33000 --automateAll --keepAutomated --gameMode exploration --setDungeonRng 120 --setMainRng 47 --frontendNull --noAnim +RTS -s -A1M -RTS + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 1 --maxFps 100000 --benchmark --stopAfterFrames 33000 --automateAll --keepAutomated --gameMode crawl --setDungeonRng 120 --setMainRng 47 --frontendNull --noAnim +RTS -s -A1M -RTS benchBattle: dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 1500 --automateAll --keepAutomated --gameMode battle --setDungeonRng 7 --setMainRng 7 @@ -65,31 +65,31 @@ benchFrontendBattle: dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 3 --noAnim --maxFps 100000 --benchmark --stopAfterFrames 1500 --automateAll --keepAutomated --gameMode battle --setDungeonRng 7 --setMainRng 7 -benchExploration: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 1 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode exploration --setDungeonRng 0 --setMainRng 0 +benchCrawl: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 1 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode crawl --setDungeonRng 0 --setMainRng 0 -benchFrontendExploration: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 1 --noAnim --maxFps 100000 --benchmark --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode exploration --setDungeonRng 0 --setMainRng 0 +benchFrontendCrawl: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 1 --noAnim --maxFps 100000 --benchmark --stopAfterFrames 7000 --automateAll --keepAutomated --gameMode crawl --setDungeonRng 0 --setMainRng 0 -benchNull: benchBattle benchAnimBattle benchExploration +benchNull: benchBattle benchAnimBattle benchCrawl -bench: benchBattle benchAnimBattle benchFrontendBattle benchExploration benchFrontendExploration +bench: benchBattle benchAnimBattle benchFrontendBattle benchCrawl benchFrontendCrawl -nativeBenchExploration: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode exploration --setDungeonRng 0 --setMainRng 0 +nativeBenchCrawl: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode crawl --setDungeonRng 0 --setMainRng 0 nativeBenchBattle: dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 1000 --automateAll --keepAutomated --gameMode battle --setDungeonRng 0 --setMainRng 0 -nativeBench: nativeBenchBattle nativeBenchExploration +nativeBench: nativeBenchBattle nativeBenchCrawl -nodeBenchExploration: - node dist/build/LambdaHack/LambdaHack.jsexe/all.js --dbgMsgSer --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode exploration --setDungeonRng 0 --setMainRng 0 +nodeBenchCrawl: + node dist/build/LambdaHack/LambdaHack.jsexe/all.js --dbgMsgSer --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 2000 --automateAll --keepAutomated --gameMode crawl --setDungeonRng 0 --setMainRng 0 nodeBenchBattle: node dist/build/LambdaHack/LambdaHack.jsexe/all.js --dbgMsgSer --newGame 3 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 1000 --automateAll --keepAutomated --gameMode battle --setDungeonRng 0 --setMainRng 0 -nodeBench: nodeBenchBattle nodeBenchExploration +nodeBench: nodeBenchBattle nodeBenchCrawl test-travis-short: test-short @@ -100,7 +100,7 @@ test-short: test-short-new test-short-load -test-medium: testRaid-medium testBrawl-medium testShootout-medium testEscape-medium testZoo-medium testAmbush-medium testExploration-medium testSafari-medium testSafariSurvival-medium testBattle-medium testBattleSurvival-medium +test-medium: testRaid-medium testBrawl-medium testShootout-medium testEscape-medium testZoo-medium testAmbush-medium testCrawl-medium testSafari-medium testSafariSurvival-medium testBattle-medium testBattleSurvival-medium testRaid-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode raid 2> /tmp/teletypetest.log @@ -120,8 +120,8 @@ testAmbush-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode ambush 2> /tmp/teletypetest.log -testExploration-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 1 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 200 --dumpInitRngs --automateAll --keepAutomated --gameMode exploration 2> /tmp/teletypetest.log +testCrawl-medium: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 1 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 200 --dumpInitRngs --automateAll --keepAutomated --gameMode crawl 2> /tmp/teletypetest.log testSafari-medium: dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 2 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 100 --dumpInitRngs --automateAll --keepAutomated --gameMode safari 2> /tmp/teletypetest.log @@ -136,7 +136,7 @@ dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 7 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 60 --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" 2> /tmp/teletypetest.log testDefense-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 9 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 500 --dumpInitRngs --automateAll --keepAutomated --gameMode defense 2> /tmp/teletypetest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 9 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterSeconds 300 --dumpInitRngs --automateAll --keepAutomated --gameMode defense 2> /tmp/teletypetest.log test-short-new: dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix raid --dumpInitRngs --automateAll --keepAutomated --gameMode raid --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log @@ -145,7 +145,7 @@ dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix escape --dumpInitRngs --automateAll --keepAutomated --gameMode escape --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix zoo --dumpInitRngs --automateAll --keepAutomated --gameMode zoo --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix exploration --dumpInitRngs --automateAll --keepAutomated --gameMode exploration --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix crawl --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --newGame 5 --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log @@ -160,7 +160,7 @@ dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix escape --dumpInitRngs --automateAll --keepAutomated --gameMode escape --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix zoo --dumpInitRngs --automateAll --keepAutomated --gameMode zoo --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix exploration --dumpInitRngs --automateAll --keepAutomated --gameMode exploration --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix crawl --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log dist/build/LambdaHack/LambdaHack --dbgMsgSer --boostRandomItem --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendTeletype --stopAfterSeconds 2 --setDungeonRng 0 --setMainRng 0 2> /tmp/teletypetest.log @@ -190,3 +190,6 @@ build-binary: build-binary-common cp LambdaHackTheGameInstall/bin/LambdaHack LambdaHackTheGame tar -czf LambdaHack_x_ubuntu-16.04-amd64.tar.gz LambdaHackTheGame + +new-build-dev: + cabal new-build --datadir=. --disable-optimization -j1 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -166,15 +166,7 @@ cabal install -fvty -To compile with GTK2 (deprecated but still supported; beware that -the font is not square and special position highlights are annoying), -you need GTK libraries for your OS. On Windows follow the same steps -as for Wine[13]. On OSX, if you encounter problems, you may want to -compile the GTK libraries from sources[14]. Invoke Cabal as follows - cabal install -fgtk gtk2hs-buildtools . - - Testing and debugging --------------------- @@ -187,8 +179,8 @@ with the standard, user-friendly frontend. Run `LambdaHack --help` to see a brief description of all debug options. -Of these, `--sniffIn` and `--sniffOut` are very useful (though verbose -and initially cryptic), for monitoring the traffic between clients +Of these, the `--sniff` option is very useful (though verbose +and initially cryptic), for displaying the traffic between clients and the server. Some options in the config file may prove useful too, though they mostly overlap with commandline options (and will be totally merged at some point). @@ -209,6 +201,26 @@ because HPC requires a clean exit to save data files. +Coding style +------------ + +Stylish Haskell is used for slight auto-formatting at buffer save; see +[.stylish-haskell.yaml](https://github.com/LambdaHack/LambdaHack/blob/master/.stylish-haskell.yaml). +As defined in the file, indentation is 2 spaces wide and screen is +80-columns wide. Spaces are used, not tabs. Spurious whitespace avoided. +Spaces around arithmetic operators encouraged. +Generally, relax and try to stick to the style apparent in a file +you are editing. Put big formatting changes in separate commits. + +Haddocks are provided for all module headers and for all functions and types +from major modules, in particular the modules that are interfaces +for a whole directory of modules. Apart of that only very important +functions and types are distinguished by having a haddock. +If minor ones have comments, they should not be haddocks +and they are permitted to describe implementation details and be out of date. +Prefer assertions in place of comments, unless too verbose. + + Further information ------------------- @@ -232,8 +244,6 @@ [9]: https://github.com/LambdaHack/LambdaHack/wiki/Sample-dungeon-crawler [10]: https://github.com/AllureOfTheStars/Allure [11]: https://github.com/LambdaHack/LambdaHack/releases/latest -[13]: http://www.haskell.org/haskellwiki/GHC_under_Wine#Code_that_uses_gtk2hs -[14]: http://www.edsko.net/2014/04/27/haskell-including-gtk-on-mavericks [15]: https://github.com/ghcjs/ghcjs [16]: https://www.npmjs.com/package/google-closure-compiler [17]: https://ci.appveyor.com/project/Mikolaj/lambdahack-4hh0j/build/artifacts diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,10 +1,15 @@ import Prelude () +import Options.Applicative + import Game.LambdaHack.Common.Prelude +import Game.LambdaHack.Server import TieKnot main :: IO () -main = - tieKnot $ words "--dbgMsgSer --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 100 --automateAll --keepAutomated --gameMode exploration --setDungeonRng 42 --setMainRng 42" +main = do + let args = words "--dbgMsgSer --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 100 --automateAll --keepAutomated --gameMode crawl --setDungeonRng 42 --setMainRng 42" + serverOptions <- handleParseResult $ execParserPure defaultPrefs serverOptionsPI args + tieKnot serverOptions -- tieKnot $ words "--dbgMsgSer --newGame 2 --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfterFrames 100 --automateAll --keepAutomated --gameMode battle --setDungeonRng 42 --setMainRng 42"