diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,30 @@ -## [v0.4.100.0, aka 'The last thaw'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.99.0..v0.4.100.0) +## [v0.4.101.0, aka 'Officially fun'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.100.0...v0.4.101.0) + +- the game is now officially fun to play +- introduce unique boss monsters and unique artifact items +- add animals that heal the player +- let AI gang up, attempt stealth and react to player aggressiveness +- spawn actors fast and close to the enemy +- spawn actors less and less often on a given level, but with growing depth +- prefer weapons with effects, if recharged +- make the bracing melee bonus additive, not multiplicative +- let explosions buffet actors around +- make braced actors immune to translocation effects +- use mouse for movement, actor selection, aiming +- don't run straight with selected actors, but go-to cross-hair with them +- speed up default frame rate, slot down projectiles visually +- rework item manipulation UI +- you can pick up many items at once and it costs only one turn +- allow actors to apply and project from the shared stash +- reverse messages shown in player diary +- display actor organs and stats +- split highscore tables wrt game modes +- move score calculation formula to content +- don't keep the default/example config file commented out; was misleading +- I was naughty again and changed v0.5.0.0 of LambdaHack content API slightly + one last time + +## [v0.4.100.0, aka 'The last thaw'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.99.0...v0.4.100.0) - unexpectedly thaw and freeze again v0.5.0.0 of LambdaHack content API - unexpectedly implement timeouts and temporary effects easily without FRP diff --git a/Game/LambdaHack/Atomic.hs b/Game/LambdaHack/Atomic.hs --- a/Game/LambdaHack/Atomic.hs +++ b/Game/LambdaHack/Atomic.hs @@ -1,14 +1,14 @@ --- | Atomic game state transformations. TODO: haddocks. +-- | Atomic game state transformations. -- -- See -- . module Game.LambdaHack.Atomic - ( -- * Re-exported from MonadAtomic + ( -- * Re-exported from "Game.LambdaHack.Atomic.MonadAtomic" MonadAtomic(..) , broadcastUpdAtomic, broadcastSfxAtomic - -- * Re-exported from CmdAtomic + -- * Re-exported from "Game.LambdaHack.Atomic.CmdAtomic" , CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), HitAtomic(..) - -- * Re-exported from PosAtomicRead + -- * Re-exported from "Game.LambdaHack.Atomic.PosAtomicRead" , PosAtomic(..), posUpdAtomic, posSfxAtomic, seenAtomicCli, generalMoveItem ) where diff --git a/Game/LambdaHack/Atomic/BroadcastAtomicWrite.hs b/Game/LambdaHack/Atomic/BroadcastAtomicWrite.hs --- a/Game/LambdaHack/Atomic/BroadcastAtomicWrite.hs +++ b/Game/LambdaHack/Atomic/BroadcastAtomicWrite.hs @@ -37,7 +37,7 @@ handleCmdAtomicServer :: forall m. MonadStateWrite m => PosAtomic -> CmdAtomic -> m () handleCmdAtomicServer posAtomic atomic = - when (seenAtomicSer posAtomic) $ do + when (seenAtomicSer posAtomic) $ -- storeUndo atomic handleCmdAtomic atomic @@ -69,15 +69,14 @@ psBroken <- mapM posSfxAtomic atomicBroken return (ps, False, map SfxAtomic atomicBroken, psBroken) let atomicPsBroken = zip atomicBroken psBroken - -- TODO: assert also that the sum of psBroken is equal to ps - -- TODO: with deep equality these assertions can be expensive. Optimize. - assert (case ps of - PosSight{} -> True - PosFidAndSight{} -> True - PosFidAndSer (Just _) _ -> True - _ -> not resets - && (null atomicBroken - || atomicBroken == [atomic])) skip + -- TODO: assert also that the sum of psBroken is equal to ps; + -- with deep equality these assertions can be expensive; optimize. + let !_A = assert (case ps of + PosSight{} -> True + PosFidAndSight{} -> True + PosFidAndSer (Just _) _ -> True + _ -> not resets + `blame` (ps, resets)) () -- Perform the action on the server. handleCmdAtomicServer ps atomic -- Update lights in the dungeon. This is lazy, may not be needed or partially. @@ -85,7 +84,7 @@ -- Send some actions to the clients, one faction at a time. let sendUI fid cmdUI = when (fhasUI $ gplayer $ factionD EM.! fid) $ doSendUpdateUI fid cmdUI - sendAI fid cmdAI = doSendUpdateAI fid cmdAI + sendAI = doSendUpdateAI sendA fid cmd = do sendUI fid $ RespUpdAtomicUI cmd sendAI fid $ RespUpdAtomicAI cmd @@ -126,12 +125,11 @@ let remember = atomicRemember lid inPer sOld seenNew = seenAtomicCli False fid perNew seenOld = seenAtomicCli False fid perOld - -- TODO: these assertions are probably expensive psRem <- mapM posUpdAtomic remember -- Verify that we remember only currently seen things. - assert (allB seenNew psRem) skip + let !_A = assert (allB seenNew psRem) () -- Verify that we remember only new things. - assert (allB (not . seenOld) psRem) skip + let !_A = assert (allB (not . seenOld) psRem) () mapM_ (sendA fid) remember anySend lid fid perOld perNew else anySend lid fid perOld perOld 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 @@ -17,6 +17,7 @@ , undoUpdAtomic, undoSfxAtomic, undoCmdAtomic ) where +import Control.Applicative import Data.Binary import Data.Int (Int64) import GHC.Generics (Generic) @@ -24,7 +25,6 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color -import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind @@ -37,18 +37,23 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ItemKind (ItemKind) -import Game.LambdaHack.Content.ModeKind +import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK +-- | Abstract syntax of atomic commands, that is, atomic game state +-- transformations. data CmdAtomic = - UpdAtomic !UpdAtomic - | SfxAtomic !SfxAtomic + UpdAtomic !UpdAtomic -- ^ atomic updates + | SfxAtomic !SfxAtomic -- ^ atomic special effects deriving (Show, Eq, Generic) instance Binary CmdAtomic --- | Abstract syntax of atomic commands. +-- | Abstract syntax of atomic updates, that is, atomic commands +-- 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. data UpdAtomic = -- Create/destroy actors and items. UpdCreateActor !ActorId !Actor ![(ItemId, Item)] @@ -68,7 +73,7 @@ | UpdAgeActor !ActorId !(Delta Time) | UpdRefillHP !ActorId !Int64 | UpdRefillCalm !ActorId !Int64 - | UpdOldFidActor !ActorId !FactionId !FactionId + | UpdFidImpressedActor !ActorId !FactionId !FactionId | UpdTrajectory !ActorId !(Maybe ([Vector], Speed)) !(Maybe ([Vector], Speed)) | UpdColorActor !ActorId !Color.Color !Color.Color -- Change faction attributes. @@ -92,15 +97,14 @@ -- Assorted. | UpdTimeItem !ItemId !Container !ItemTimer !ItemTimer | UpdAgeGame !(Delta Time) ![LevelId] - | UpdDiscover !LevelId !Point !ItemId !(Kind.Id ItemKind) !ItemSeed - | UpdCover !LevelId !Point !ItemId !(Kind.Id ItemKind) !ItemSeed - | UpdDiscoverKind !LevelId !Point !ItemId !(Kind.Id ItemKind) - | UpdCoverKind !LevelId !Point !ItemId !(Kind.Id ItemKind) - | UpdDiscoverSeed !LevelId !Point !ItemId !ItemSeed - | UpdCoverSeed !LevelId !Point !ItemId !ItemSeed + | 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) + | UpdDiscoverSeed !Container !ItemId !ItemSeed + | UpdCoverSeed !Container !ItemId !ItemSeed | UpdPerception !LevelId !Perception !Perception - | UpdRestart - !FactionId !DiscoveryKind !FactionPers !State !DebugModeCli !(GroupName ModeKind) + | UpdRestart !FactionId !DiscoveryKind !FactionPers !State !DebugModeCli | UpdRestartServer !State | UpdResume !FactionId !FactionPers | UpdResumeServer !State @@ -112,17 +116,18 @@ instance Binary UpdAtomic --- | Abstract syntax of atomic special effects. +-- | Abstract syntax of atomic special effects, that is, atomic commands +-- that only display special effects and don't change the state. data SfxAtomic = - SfxStrike !ActorId !ActorId !ItemId !HitAtomic - | SfxRecoil !ActorId !ActorId !ItemId !HitAtomic + SfxStrike !ActorId !ActorId !ItemId !CStore !HitAtomic + | SfxRecoil !ActorId !ActorId !ItemId !CStore !HitAtomic | SfxProject !ActorId !ItemId !CStore | SfxCatch !ActorId !ItemId !CStore - | SfxActivate !ActorId !ItemId !CStore + | SfxApply !ActorId !ItemId !CStore | SfxCheck !ActorId !ItemId !CStore | SfxTrigger !ActorId !Point !TK.Feature | SfxShun !ActorId !Point !TK.Feature - | SfxEffect !FactionId !ActorId !(IK.Effect) + | SfxEffect !FactionId !ActorId !IK.Effect | SfxMsgFid !FactionId !Msg | SfxMsgAll !Msg | SfxActorStart !ActorId @@ -130,6 +135,7 @@ instance Binary SfxAtomic +-- | Determine if a strike special effect should depict a block of an attack. data HitAtomic = HitClear | HitBlock !Int deriving (Show, Eq, Generic) @@ -152,7 +158,8 @@ UpdAgeActor aid delta -> Just $ UpdAgeActor aid (timeDeltaReverse delta) UpdRefillHP aid n -> Just $ UpdRefillHP aid (-n) UpdRefillCalm aid n -> Just $ UpdRefillCalm aid (-n) - UpdOldFidActor aid fromFid toFid -> Just $ UpdOldFidActor aid toFid fromFid + UpdFidImpressedActor aid fromFid toFid -> + Just $ UpdFidImpressedActor aid toFid fromFid UpdTrajectory aid fromT toT -> Just $ UpdTrajectory aid toT fromT UpdColorActor aid fromCol toCol -> Just $ UpdColorActor aid toCol fromCol UpdQuitFaction fid mb fromSt toSt -> Just $ UpdQuitFaction fid mb toSt fromSt @@ -175,12 +182,12 @@ UpdLoseSmell lid sms -> Just $ UpdSpotSmell lid sms UpdTimeItem iid c fromIt toIt -> Just $ UpdTimeItem iid c toIt fromIt UpdAgeGame delta lids -> Just $ UpdAgeGame (timeDeltaReverse delta) lids - UpdDiscover lid p iid ik seed -> Just $ UpdCover lid p iid ik seed - UpdCover lid p iid ik seed -> Just $ UpdDiscover lid p iid ik seed - UpdDiscoverKind lid p iid ik -> Just $ UpdCoverKind lid p iid ik - UpdCoverKind lid p iid ik -> Just $ UpdDiscoverKind lid p iid ik - UpdDiscoverSeed lid p iid seed -> Just $ UpdCoverSeed lid p iid seed - UpdCoverSeed lid p iid seed -> Just $ UpdDiscoverSeed lid p iid seed + 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 + UpdDiscoverSeed c iid seed -> Just $ UpdCoverSeed c iid seed + UpdCoverSeed c iid seed -> Just $ UpdDiscoverSeed c iid seed 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 @@ -193,12 +200,12 @@ undoSfxAtomic :: SfxAtomic -> SfxAtomic undoSfxAtomic cmd = case cmd of - SfxStrike source target iid b -> SfxRecoil source target iid b - SfxRecoil source target iid b -> SfxStrike source target iid b + SfxStrike source target iid cstore b -> SfxRecoil source target iid cstore b + SfxRecoil source target iid cstore b -> SfxStrike source target iid cstore b SfxProject aid iid cstore -> SfxCatch aid iid cstore SfxCatch aid iid cstore -> SfxProject aid iid cstore - SfxActivate aid iid cstore -> SfxCheck aid iid cstore - SfxCheck aid iid cstore -> SfxActivate aid iid cstore + SfxApply aid iid cstore -> SfxCheck aid iid cstore + SfxCheck aid iid cstore -> SfxApply aid iid cstore SfxTrigger aid p feat -> SfxShun aid p feat SfxShun aid p feat -> SfxTrigger aid p feat SfxEffect{} -> cmd -- not ideal? @@ -207,5 +214,5 @@ SfxActorStart{} -> cmd undoCmdAtomic :: CmdAtomic -> Maybe CmdAtomic -undoCmdAtomic (UpdAtomic cmd) = fmap UpdAtomic $ undoUpdAtomic cmd +undoCmdAtomic (UpdAtomic cmd) = UpdAtomic <$> undoUpdAtomic cmd undoCmdAtomic (SfxAtomic sfx) = Just $ SfxAtomic $ undoSfxAtomic sfx 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 @@ -60,7 +60,8 @@ UpdAgeActor aid t -> updAgeActor aid t UpdRefillHP aid n -> updRefillHP aid n UpdRefillCalm aid n -> updRefillCalm aid n - UpdOldFidActor aid fromFid toFid -> updOldFidActor aid fromFid toFid + UpdFidImpressedActor aid fromFid toFid -> + updFidImpressedActor aid fromFid toFid UpdTrajectory aid fromT toT -> updTrajectory aid fromT toT UpdColorActor aid fromCol toCol -> updColorActor aid fromCol toCol UpdQuitFaction fid mbody fromSt toSt -> updQuitFaction fid mbody fromSt toSt @@ -89,8 +90,8 @@ UpdDiscoverSeed{} -> return () UpdCoverSeed{} -> return () UpdPerception _ outPer inPer -> - assert (not (nullPer outPer && nullPer inPer)) skip - UpdRestart _ _ _ s _ _ -> updRestart s + assert (not (nullPer outPer && nullPer inPer)) (return ()) + UpdRestart _ _ _ s _ -> updRestart s UpdRestartServer s -> updRestartServer s UpdResume{} -> return () UpdResumeServer s -> updResumeServer s @@ -146,8 +147,8 @@ -- that do not appear anywhere else, for simplicity and speed. itemD <- getsState sitemD let match (iid, item) = itemsMatch (itemD EM.! iid) item - assert (allB match ais `blame` "destroyed actor items not found" - `twith` (aid, body, ais, itemD)) skip + let !_A = assert (allB match ais `blame` "destroyed actor items not found" + `twith` (aid, body, ais, itemD)) () -- Remove actor from @sactorD@. let f Nothing = assert `failure` "actor already removed" `twith` (aid, body) f (Just b) = assert (b == body `blame` "inconsistent destroyed actor body" @@ -175,34 +176,35 @@ modifyState $ updateItemD $ EM.insertWith f iid item insertItemContainer iid kit c --- TODO: verify kit -- | Destroy some copies (possibly not all) of an item. updDestroyItem :: MonadStateWrite m => ItemId -> Item -> ItemQuant -> Container -> m () -updDestroyItem iid item (k, _) c = assert (k > 0) $ do +updDestroyItem iid item kit@(k, _) c = assert (k > 0) $ do -- 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@. itemD <- getsState sitemD - assert ((case iid `EM.lookup` itemD of - Nothing -> False - Just item0 -> itemsMatch item0 item) - `blame` "item already removed" - `twith` (iid, item, itemD)) skip - deleteItemContainer iid k c + let !_A = assert ((case iid `EM.lookup` itemD of + Nothing -> False + Just item0 -> itemsMatch item0 item) + `blame` "item already removed" + `twith` (iid, item, itemD)) () + deleteItemContainer iid kit c updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m () updMoveActor aid fromP toP = assert (fromP /= toP) $ do b <- getsState $ getActorBody aid - assert (fromP == bpos b `blame` "unexpected moved actor position" - `twith` (aid, fromP, toP, bpos b, b)) skip + let !_A = assert (fromP == bpos b + `blame` "unexpected moved actor position" + `twith` (aid, fromP, toP, bpos b, b)) () updateActor aid $ \body -> body {bpos = toP, boldpos = fromP} updWaitActor :: MonadStateWrite m => ActorId -> Bool -> m () updWaitActor aid toWait = do b <- getsState $ getActorBody aid - assert (toWait /= bwait b `blame` "unexpected waited actor time" - `twith` (aid, toWait, bwait b, b)) skip + let !_A = assert (toWait /= bwait b + `blame` "unexpected waited actor time" + `twith` (aid, toWait, bwait b, b)) () updateActor aid $ \body -> body {bwait = toWait} updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m () @@ -220,17 +222,31 @@ case iid `EM.lookup` bag of Nothing -> assert `failure` (iid, k, aid, c1, c2) Just (_, it) -> do - deleteItemActor iid k aid c1 + deleteItemActor iid (k, take k it) aid c1 insertItemActor iid (k, take k it) aid c2 --- TODO: optimize (a single call to updatePrio is enough) +-- This is equaivalent to (but much cheaper than) updDestroyActor +-- followed by updCreateActor. updAgeActor :: MonadStateWrite m => ActorId -> Delta Time -> m () updAgeActor aid delta = assert (delta /= Delta timeZero) $ do body <- getsState $ getActorBody aid - ais <- getsState $ getCarriedAssocs body - updDestroyActor aid body ais let newBody = body {btime = timeShift (btime body) delta} - updCreateActor aid newBody ais + -- Remove actor from @sprio@ at old time. + rmPrio Nothing = assert `failure` "actor already removed" + `twith` (aid, body) + rmPrio (Just l) = assert (aid `elem` l `blame` "actor already removed" + `twith` (aid, body, l)) + $ let l2 = delete aid l + in if null l2 then Nothing else Just l2 + -- Add actor to @sprio@ at new time. + addPrio Nothing = Just [aid] + addPrio (Just l) = assert (aid `notElem` l `blame` "actor already added" + `twith` (aid, body, l)) + $ Just $ aid : l + updPrio = EM.alter addPrio (btime newBody) . EM.alter rmPrio (btime body) + updateLevel (blid body) $ updatePrio updPrio + -- Modify actor body in @sactorD@. + modifyState $ updateActorD $ EM.adjust (const newBody) aid updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m () updRefillHP aid n = @@ -254,11 +270,11 @@ else oldD {resCurrentTurn = resCurrentTurn oldD + n} } -updOldFidActor :: MonadStateWrite m => ActorId -> FactionId -> FactionId -> m () -updOldFidActor aid fromFid toFid = assert (fromFid /= toFid) $ do +updFidImpressedActor :: MonadStateWrite m => ActorId -> FactionId -> FactionId -> m () +updFidImpressedActor aid fromFid toFid = assert (fromFid /= toFid) $ updateActor aid $ \b -> - assert (boldfid b == fromFid `blame` (aid, fromFid, toFid, b)) - $ b {boldfid = toFid} + assert (bfidImpressed b == fromFid `blame` (aid, fromFid, toFid, b)) + $ b {bfidImpressed = toFid} updTrajectory :: MonadStateWrite m => ActorId @@ -267,27 +283,30 @@ -> m () updTrajectory aid fromT toT = assert (fromT /= toT) $ do body <- getsState $ getActorBody aid - assert (fromT == btrajectory body `blame` "unexpected actor trajectory" - `twith` (aid, fromT, toT, body)) skip + let !_A = assert (fromT == btrajectory body + `blame` "unexpected actor trajectory" + `twith` (aid, fromT, toT, body)) () updateActor aid $ \b -> b {btrajectory = toT} updColorActor :: MonadStateWrite m => ActorId -> Color.Color -> Color.Color -> m () updColorActor aid fromCol toCol = assert (fromCol /= toCol) $ do body <- getsState $ getActorBody aid - assert (fromCol == bcolor body `blame` "unexpected actor color" - `twith` (aid, fromCol, toCol, body)) skip + let !_A = assert (fromCol == bcolor body + `blame` "unexpected actor color" + `twith` (aid, fromCol, toCol, body)) () updateActor aid $ \b -> b {bcolor = toCol} updQuitFaction :: MonadStateWrite m => FactionId -> Maybe Actor -> Maybe Status -> Maybe Status -> m () updQuitFaction fid mbody fromSt toSt = do - assert (fromSt /= toSt `blame` (fid, mbody, fromSt, toSt)) skip - assert (maybe True ((fid ==) . bfid) mbody) skip + let !_A = assert (fromSt /= toSt `blame` (fid, mbody, fromSt, toSt)) () + let !_A = assert (maybe True ((fid ==) . bfid) mbody) () fact <- getsState $ (EM.! fid) . sfactionD - assert (fromSt == gquit fact `blame` "unexpected actor quit status" - `twith` (fid, fromSt, toSt, fact)) skip + let !_A = assert (fromSt == gquit fact + `blame` "unexpected actor quit status" + `twith` (fid, fromSt, toSt, fact)) () let adj fa = fa {gquit = toSt} updateFaction fid adj @@ -299,14 +318,14 @@ -> m () updLeadFaction fid source target = assert (source /= target) $ do fact <- getsState $ (EM.! fid) . sfactionD - assert (fleaderMode (gplayer fact) /= LeaderNull) skip + let !_A = assert (fleaderMode (gplayer fact) /= LeaderNull) () -- @PosNone@ ensures this mtb <- getsState $ \s -> flip getActorBody s . fst <$> target - assert (maybe True (not . bproj) mtb - `blame` (fid, source, target, mtb, fact)) skip - assert (source == gleader fact - `blame` "unexpected actor leader" - `twith` (fid, source, target, mtb, fact)) skip + let !_A = assert (maybe True (not . bproj) mtb + `blame` (fid, source, target, mtb, fact)) () + let !_A = assert (source == gleader fact + `blame` "unexpected actor leader" + `twith` (fid, source, target, mtb, fact)) () let adj fa = fa {gleader = target} updateFaction fid adj @@ -316,10 +335,10 @@ assert (fid1 /= fid2 && fromDipl /= toDipl) $ do fact1 <- getsState $ (EM.! fid1) . sfactionD fact2 <- getsState $ (EM.! fid2) . sfactionD - assert (fromDipl == EM.findWithDefault Unknown fid2 (gdipl fact1) - && fromDipl == EM.findWithDefault Unknown fid1 (gdipl fact2) - `blame` "unexpected actor diplomacy status" - `twith` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) skip + let !_A = assert (fromDipl == EM.findWithDefault Unknown fid2 (gdipl fact1) + && fromDipl == EM.findWithDefault Unknown fid1 (gdipl fact2) + `blame` "unexpected actor diplomacy status" + `twith` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) () let adj fid fact = fact {gdipl = EM.insert fid toDipl (gdipl fact)} updateFaction fid1 (adj fid2) updateFaction fid2 (adj fid1) @@ -343,12 +362,12 @@ updRecordKill :: MonadStateWrite m => ActorId -> Kind.Id ItemKind -> Int -> m () updRecordKill aid ikind k = do b <- getsState $ getActorBody aid - assert (not (bproj b) `blame` (aid, b)) skip + let !_A = assert (not (bproj b) `blame` (aid, b)) let alterKind mn = let n = fromMaybe 0 mn + k in if n == 0 then Nothing else Just n adjFact fact = fact {gvictims = EM.alter alterKind ikind $ gvictims fact} - updateFaction (bfid b) adjFact + updateFaction (bfidOriginal b) adjFact -- | Alter an attribute (actually, the only, the defining attribute) -- of a visible tile. This is similar to e.g., @UpdTrajectory@. @@ -458,8 +477,8 @@ bag <- getsState $ getCBag c case iid `EM.lookup` bag of Just (k, it) -> do - assert (fromIt == it `blame` (k, it, iid, c, fromIt, toIt)) skip - deleteItemContainer iid k c + let !_A = assert (fromIt == it `blame` (k, it, iid, c, fromIt, toIt)) () + deleteItemContainer iid (k, fromIt) c insertItemContainer iid (k, toIt) c Nothing -> assert `failure` (bag, iid, c, fromIt, toIt) diff --git a/Game/LambdaHack/Atomic/MonadAtomic.hs b/Game/LambdaHack/Atomic/MonadAtomic.hs --- a/Game/LambdaHack/Atomic/MonadAtomic.hs +++ b/Game/LambdaHack/Atomic/MonadAtomic.hs @@ -1,4 +1,4 @@ --- | Atomic monads. +-- | Atomic monads for handling atomic game state transformations. module Game.LambdaHack.Atomic.MonadAtomic ( MonadAtomic(..) , broadcastUpdAtomic, broadcastSfxAtomic @@ -7,23 +7,29 @@ import Data.Key (mapWithKeyM_) import Game.LambdaHack.Atomic.CmdAtomic -import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State +-- | The monad for executing atomic game state transformations. class MonadStateRead m => MonadAtomic m where + -- | Execute an arbitrary atomic game state transformation. execAtomic :: CmdAtomic -> m () + -- | Execute an atomic command that really changes the state. execUpdAtomic :: UpdAtomic -> m () execUpdAtomic = execAtomic . UpdAtomic + -- | Execute an atomic command that only displays special effects. execSfxAtomic :: SfxAtomic -> m () execSfxAtomic = execAtomic . SfxAtomic +-- | Create and broadcast a set of atomic updates, one for each client. broadcastUpdAtomic :: MonadAtomic m => (FactionId -> UpdAtomic) -> m () broadcastUpdAtomic fcmd = do factionD <- getsState sfactionD mapWithKeyM_ (\fid _ -> execUpdAtomic $ fcmd fid) factionD +-- | Create and broadcast a set of atomic special effects, one for each client. broadcastSfxAtomic :: MonadAtomic m => (FactionId -> SfxAtomic) -> m () broadcastSfxAtomic fcmd = do 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 @@ -124,71 +124,73 @@ updateFaction fid $ \fact -> fact {gsha = upd (gsha fact)} deleteItemContainer :: MonadStateWrite m - => ItemId -> Int -> Container -> m () -deleteItemContainer iid k c = case c of - CFloor lid pos -> deleteItemFloor iid k lid pos - CEmbed lid pos -> deleteItemEmbed iid k lid pos - CActor aid store -> deleteItemActor iid k aid store - CTrunk{} -> return () + => ItemId -> ItemQuant -> Container -> m () +deleteItemContainer iid kit c = case c of + CFloor lid pos -> deleteItemFloor iid kit lid pos + CEmbed lid pos -> deleteItemEmbed iid kit lid pos + CActor aid store -> deleteItemActor iid kit aid store + CTrunk{} -> assert `failure` c deleteItemFloor :: MonadStateWrite m - => ItemId -> Int -> LevelId -> Point -> m () -deleteItemFloor iid k lid pos = + => ItemId -> ItemQuant -> LevelId -> Point -> m () +deleteItemFloor iid kit lid pos = let rmFromFloor (Just bag) = - let nbag = rmFromBag k iid bag + let nbag = rmFromBag kit iid bag in if EM.null nbag then Nothing else Just nbag rmFromFloor Nothing = assert `failure` "item already removed" - `twith` (iid, k, lid, pos) + `twith` (iid, kit, lid, pos) in updateLevel lid $ updateFloor $ EM.alter rmFromFloor pos deleteItemEmbed :: MonadStateWrite m - => ItemId -> Int -> LevelId -> Point -> m () -deleteItemEmbed iid k lid pos = + => ItemId -> ItemQuant -> LevelId -> Point -> m () +deleteItemEmbed iid kit lid pos = let rmFromFloor (Just bag) = - let nbag = rmFromBag k iid bag + let nbag = rmFromBag kit iid bag in if EM.null nbag then Nothing else Just nbag rmFromFloor Nothing = assert `failure` "item already removed" - `twith` (iid, k, lid, pos) + `twith` (iid, kit, lid, pos) in updateLevel lid $ updateEmbed $ EM.alter rmFromFloor pos deleteItemActor :: MonadStateWrite m - => ItemId -> Int -> ActorId -> CStore -> m () -deleteItemActor iid k aid cstore = case cstore of + => ItemId -> ItemQuant -> ActorId -> CStore -> m () +deleteItemActor iid kit aid cstore = case cstore of CGround -> do b <- getsState $ getActorBody aid - deleteItemFloor iid k (blid b) (bpos b) - COrgan -> deleteItemBody iid k aid - CEqp -> deleteItemEqp iid k aid - CInv -> deleteItemInv iid k aid + deleteItemFloor iid kit (blid b) (bpos b) + COrgan -> deleteItemBody iid kit aid + CEqp -> deleteItemEqp iid kit aid + CInv -> deleteItemInv iid kit aid CSha -> do b <- getsState $ getActorBody aid - deleteItemSha iid k (bfid b) + deleteItemSha iid kit (bfid b) -deleteItemBody :: MonadStateWrite m => ItemId -> Int -> ActorId -> m () -deleteItemBody iid k aid = do - updateActor aid $ \b -> b {borgan = rmFromBag k iid (borgan b) } +deleteItemBody :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () +deleteItemBody iid kit aid = + updateActor aid $ \b -> b {borgan = rmFromBag kit iid (borgan b) } -deleteItemEqp :: MonadStateWrite m => ItemId -> Int -> ActorId -> m () -deleteItemEqp iid k aid = do - updateActor aid $ \b -> b {beqp = rmFromBag k iid (beqp b)} +deleteItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () +deleteItemEqp iid kit aid = + updateActor aid $ \b -> b {beqp = rmFromBag kit iid (beqp b)} -deleteItemInv :: MonadStateWrite m => ItemId -> Int -> ActorId -> m () -deleteItemInv iid k aid = do - updateActor aid $ \b -> b {binv = rmFromBag k iid (binv b)} +deleteItemInv :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m () +deleteItemInv iid kit aid = + updateActor aid $ \b -> b {binv = rmFromBag kit iid (binv b)} -deleteItemSha :: MonadStateWrite m => ItemId -> Int -> FactionId -> m () -deleteItemSha iid k fid = do - updateFaction fid $ \fact -> fact {gsha = rmFromBag k iid (gsha fact)} +deleteItemSha :: MonadStateWrite m => ItemId -> ItemQuant -> FactionId -> m () +deleteItemSha iid kit fid = + updateFaction fid $ \fact -> fact {gsha = rmFromBag kit iid (gsha fact)} -- Removing the part of the kit from the front of the list, -- so that @DestroyItem kit (CreateItem kit x) == x@. -rmFromBag :: Int -> ItemId -> ItemBag -> ItemBag -rmFromBag k iid bag = +rmFromBag :: ItemQuant -> ItemId -> ItemBag -> ItemBag +rmFromBag kit@(k, rmIt) iid bag = let rfb Nothing = assert `failure` "rm from empty slot" `twith` (k, iid, bag) rfb (Just (n, it)) = case compare n k of LT -> assert `failure` "rm more than there is" - `twith` (n, k, iid, bag) + `twith` (n, kit, iid, bag) EQ -> Nothing - GT -> Just (n - k, drop k it) + GT -> assert (rmIt == take k it + `blame` (rmIt, take k it, n, kit, iid, bag)) + $ Just (n - k, drop k it) in EM.alter rfb iid bag 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 @@ -16,7 +16,6 @@ import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState -import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind @@ -28,13 +27,15 @@ import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile +import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind -- All functions here that take an atomic action are executed -- in the state just before the action is executed. --- | The type representing visibility of actions to factions, --- based on the position of the action, etc. +-- | The type representing visibility of atomic commands to factions, +-- based on the position of the command, etc. Note that the server +-- sees and smells all positions. data PosAtomic = PosSight !LevelId ![Point] -- ^ whomever sees all the positions, notices | PosFidAndSight ![FactionId] !LevelId ![Point] @@ -47,11 +48,18 @@ | PosNone -- ^ never broadcasted, but sent manually deriving (Show, Eq) --- | Produce the positions where the action takes place. --- The goal of the mechanics: client should not get significantly --- more information by looking at the atomic commands he is able to see --- than by looking at the state changes they enact. E.g., @UpdDisplaceActor@ --- in a black room, with one actor carrying a 0-radius light would not be +-- | Produce the positions where the atomic update takes place. +-- +-- 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. +-- +-- E.g., @UpdDisplaceActor@ in a black room, +-- with 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 @@ -99,7 +107,7 @@ UpdAgeActor aid _ -> singleAid aid UpdRefillHP aid _ -> singleAid aid UpdRefillCalm aid _ -> singleAid aid - UpdOldFidActor aid _ _ -> singleAid aid + UpdFidImpressedActor aid _ _ -> singleAid aid UpdTrajectory aid _ _ -> singleAid aid UpdColorActor aid _ _ -> singleAid aid UpdQuitFaction{} -> return PosAll @@ -133,14 +141,14 @@ return $! PosSmell lid ps UpdTimeItem _ c _ _ -> singleContainer c UpdAgeGame _ _ -> return PosAll - UpdDiscover lid p _ _ _ -> return $! PosSight lid [p] - UpdCover lid p _ _ _ -> return $! PosSight lid [p] - UpdDiscoverKind lid p _ _ -> return $! PosSight lid [p] - UpdCoverKind lid p _ _ -> return $! PosSight lid [p] - UpdDiscoverSeed lid p _ _ -> return $! PosSight lid [p] - UpdCoverSeed lid p _ _ -> return $! PosSight lid [p] + UpdDiscover c _ _ _ -> singleContainer c + UpdCover c _ _ _ -> singleContainer c + UpdDiscoverKind c _ _ -> singleContainer c + UpdCoverKind c _ _ -> singleContainer c + UpdDiscoverSeed c _ _ -> singleContainer c + UpdCoverSeed c _ _ -> singleContainer c UpdPerception{} -> return PosNone - UpdRestart fid _ _ _ _ _ -> return $! PosFid fid + UpdRestart fid _ _ _ _ -> return $! PosFid fid UpdRestartServer _ -> return PosSer UpdResume fid _ -> return $! PosFid fid UpdResumeServer _ -> return PosSer @@ -152,18 +160,22 @@ -- | Produce the positions where the atomic special effect takes place. posSfxAtomic :: MonadStateRead m => SfxAtomic -> m PosAtomic posSfxAtomic cmd = case cmd of - SfxStrike source target _ _ -> do + SfxStrike _ _ _ CSha _ -> -- shared stash is private + return PosNone -- TODO: PosSerAndFidIfSight; but probably never used + SfxStrike source target _ _ _ -> do (slid, sp) <- posOfAid source (tlid, tp) <- posOfAid target return $! assert (slid == tlid) $ PosSight slid [sp, tp] - SfxRecoil source target _ _ -> do + SfxRecoil _ _ _ CSha _ -> -- shared stash is private + return PosNone -- TODO: PosSerAndFidIfSight; but probably never used + SfxRecoil source target _ _ _ -> do (slid, sp) <- posOfAid source (tlid, tp) <- posOfAid target return $! assert (slid == tlid) $ PosSight slid [sp, tp] - SfxProject aid _ _ -> singleAid aid - SfxCatch aid _ _ -> singleAid aid - SfxActivate aid _ _ -> singleAid aid - SfxCheck aid _ _ -> singleAid aid + SfxProject aid _ cstore -> singleContainer $ CActor aid cstore + SfxCatch aid _ cstore -> singleContainer $ CActor aid cstore + SfxApply aid _ cstore -> singleContainer $ CActor aid cstore + SfxCheck aid _ cstore -> singleContainer $ CActor aid cstore SfxTrigger aid p _ -> do (lid, pa) <- posOfAid aid return $! PosSight lid [pa, p] @@ -273,7 +285,7 @@ -- | Decompose an atomic special effect. breakSfxAtomic :: MonadStateRead m => SfxAtomic -> m [SfxAtomic] breakSfxAtomic cmd = case cmd of - SfxStrike source target _ _ -> do + SfxStrike source target _ _ _ -> do -- Hack: make a fight detectable even if one of combatants not visible. sb <- getsState $ getActorBody source return $! [ SfxEffect (bfid sb) source (IK.RefillCalm (-1)) @@ -302,6 +314,8 @@ , MU.AW $ MU.Phrase $ distant ++ [sound] ] return $! hear <$> msound +-- | Given the client, it's perception and an atomic command, determine +-- if the client notices the command. seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool seenAtomicCli knowEvents fid per posAtomic = case posAtomic of @@ -322,10 +336,11 @@ PosNone -> False _ -> True +-- | Generate the atomic updates that jointly perform a given item move. generalMoveItem :: MonadStateRead m => ItemId -> Int -> Container -> Container -> m [UpdAtomic] -generalMoveItem iid k c1 c2 = do +generalMoveItem iid k c1 c2 = case (c1, c2) of (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2 -> return [UpdMoveItem iid k aid1 cstore1 cstore2] diff --git a/Game/LambdaHack/Client.hs b/Game/LambdaHack/Client.hs --- a/Game/LambdaHack/Client.hs +++ b/Game/LambdaHack/Client.hs @@ -4,43 +4,11 @@ -- See -- . module Game.LambdaHack.Client - ( exeFrontend + ( -- * Re-exported from "Game.LambdaHack.Client.LoopClient" + loopAI, loopUI + -- * Re-exported from "Game.LambdaHack.Client.UI" + , srtFrontend ) where -import Game.LambdaHack.Atomic import Game.LambdaHack.Client.LoopClient -import Game.LambdaHack.Client.ProtocolClient -import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI -import Game.LambdaHack.Common.ClientOptions -import Game.LambdaHack.Common.Faction -import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.Response -import Game.LambdaHack.Common.State - --- | Wire together game content, the main loop of game clients, --- the main game loop assigned to this frontend (possibly containing --- the server loop, if the whole game runs in one process), --- UI config and the definitions of game commands. -exeFrontend :: ( MonadAtomic m, MonadClientUI m - , MonadClientReadResponse ResponseUI m - , MonadClientWriteRequest RequestUI m - , MonadAtomic n - , MonadClientReadResponse ResponseAI n - , MonadClientWriteRequest RequestAI n ) - => (m () -> SessionUI -> State -> StateClient - -> chanServerUI - -> IO ()) - -> (n () -> SessionUI -> State -> StateClient - -> chanServerAI - -> IO ()) - -> KeyKind -> Kind.COps -> DebugModeCli - -> ((FactionId -> chanServerUI -> IO ()) - -> (FactionId -> chanServerAI -> IO ()) - -> IO ()) - -> IO () -exeFrontend executorUI executorAI copsClient cops sdebugCli exeServer = - srtFrontend (executorUI . loopUI) - (executorAI . loopAI) - copsClient cops sdebugCli exeServer 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 @@ -2,9 +2,9 @@ -- | Ways for the client to use AI to produce server requests, based on -- the client's view of the game state. module Game.LambdaHack.Client.AI - ( -- * Public API - queryAI, pongAI + ( queryAI, pongAI #ifdef EXPOSE_INTERNAL + -- * Internal operations , refreshTarget, pickAction #endif ) where @@ -51,16 +51,20 @@ pongAI :: MonadClient m => m RequestAI pongAI = return ReqAIPong +-- | 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. refreshTarget :: MonadClient m - => ActorId -> (ActorId, Actor) - -> m (Maybe ((ActorId, Actor), (Target, PathEtc))) -refreshTarget oldLeader (aid, body) = do + => (ActorId, Actor) -- ^ the actor to refresh + -> m (Maybe (Target, PathEtc)) +refreshTarget (aid, body) = do side <- getsClient sside - assert (bfid body == side `blame` "AI tries to move an enemy actor" - `twith` (aid, body, side)) skip - assert (not (bproj body) `blame` "AI gets to manually move its projectiles" - `twith` (aid, body, side)) skip - stratTarget <- targetStrategy oldLeader aid + let !_A = assert (bfid body == side + `blame` "AI tries to move an enemy actor" + `twith` (aid, body, side)) () + let !_A = assert (not (bproj body) + `blame` "AI gets to manually move its projectiles" + `twith` (aid, body, side)) () + stratTarget <- targetStrategy aid tgtMPath <- if nullStrategy stratTarget then -- No sensible target; wipe out the old one. @@ -79,18 +83,21 @@ <> "\nHandleAI target:" <+> tshow tgtMPath -- trace _debug skip modifyClient $ \cli -> - cli {stargetD = EM.alter (const $ tgtMPath) aid (stargetD cli)} + cli {stargetD = EM.alter (const tgtMPath) aid (stargetD cli)} return $! case tgtMPath of - Just (tgt, Just pathEtc) -> Just ((aid, body), (tgt, pathEtc)) + Just (tgt, Just pathEtc) -> Just (tgt, pathEtc) _ -> Nothing +-- | Pick an action the actor will perfrom this turn. pickAction :: MonadClient m => (ActorId, Actor) -> m RequestAnyAbility pickAction (aid, body) = do side <- getsClient sside - assert (bfid body == side `blame` "AI tries to move enemy actor" - `twith` (aid, bfid body, side)) skip - assert (not (bproj body) `blame` "AI gets to manually move its projectiles" - `twith` (aid, bfid body, side)) skip + let !_A = assert (bfid body == side + `blame` "AI tries to move enemy actor" + `twith` (aid, bfid body, side)) () + let !_A = assert (not (bproj body) + `blame` "AI gets to manually move its projectiles" + `twith` (aid, bfid body, side)) () stratAction <- actionStrategy aid -- Run the AI: chose an action from those given by the AI strategy. rndToAction $ frequency $ bestVariant stratAction diff --git a/Game/LambdaHack/Client/AI/ConditionClient.hs b/Game/LambdaHack/Client/AI/ConditionClient.hs --- a/Game/LambdaHack/Client/AI/ConditionClient.hs +++ b/Game/LambdaHack/Client/AI/ConditionClient.hs @@ -3,19 +3,24 @@ module Game.LambdaHack.Client.AI.ConditionClient ( condTgtEnemyPresentM , condTgtEnemyRememberedM + , condTgtEnemyAdjFriendM + , condTgtNonmovingM , condAnyFoeAdjM , condHpTooLowM , condOnTriggerableM , condBlocksFriendsM , condFloorWeaponM , condNoEqpWeaponM + , condEnoughGearM , condCanProjectM , condNotCalmEnoughM , condDesirableFloorItemM , condMeleeBadM , condLightBetraysM , benAvailableItems + , hinders , benGroundItems + , desirableItem , threatDistList , fleeList ) where @@ -47,8 +52,10 @@ import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile +import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK +import Game.LambdaHack.Content.ModeKind -- | Require that the target enemy is visible by the party. condTgtEnemyPresentM :: MonadClient m => ActorId -> m Bool @@ -67,6 +74,31 @@ Just (TEnemyPos _ lid _ permit) | lid == blid b -> not permit _ -> False +-- | Require that the target enemy is adjacent to at least one friend. +condTgtEnemyAdjFriendM :: MonadClient m => ActorId -> m Bool +condTgtEnemyAdjFriendM aid = do + btarget <- getsClient $ getTarget aid + case btarget of + Just (TEnemy enemy _) -> do + be <- getsState $ getActorBody enemy + b <- getsState $ getActorBody aid + fact <- getsState $ (EM.! bfid b) . sfactionD + let friendlyFid fid = fid == bfid b || isAllied fact fid + friends <- getsState $ actorRegularList friendlyFid (blid b) + return $ any (adjacent (bpos be) . bpos) friends -- keep it lazy + _ -> return False + +-- | Check if the target is nonmoving. +condTgtNonmovingM :: MonadClient m => ActorId -> m Bool +condTgtNonmovingM aid = do + btarget <- getsClient $ getTarget aid + case btarget of + Just (TEnemy enemy _) -> do + activeItems <- activeItemsClient enemy + let actorMaxSkE = sumSkills activeItems + return $! EM.findWithDefault 0 Ability.AbMove actorMaxSkE <= 0 + _ -> return False + -- | Require that any non-dying foe is adjacent. condAnyFoeAdjM :: MonadStateRead m => ActorId -> m Bool condAnyFoeAdjM aid = do @@ -102,7 +134,9 @@ allAtWar <- getsState $ actorRegularAssocs (isAtWar fact) (blid b) let strongActor (aid2, b2) = do activeItems <- activeItemsClient aid2 - return $! not $ hpTooLow b2 activeItems + let actorMaxSkE = sumSkills activeItems + nonmoving = EM.findWithDefault 0 Ability.AbMove actorMaxSkE <= 0 + return $! not $ (hpTooLow b2 activeItems || nonmoving) allThreats <- filterM strongActor allAtWar let addDist (aid2, b2) = (chessDist (bpos b) (bpos b2), (aid2, b2)) return $ sortBy (comparing fst) $ map addDist allThreats @@ -119,28 +153,37 @@ _ -> False return $ any blocked ours -- keep it lazy --- | Require the actor stands over a weapon. +-- | Require the actor stands over a weapon that would be auto-equipped. condFloorWeaponM :: MonadClient m => ActorId -> m Bool condFloorWeaponM aid = do floorAssocs <- fullAssocsClient aid [CGround] - -- We do consider OFF weapons, because e.g., enemies might have turned - -- them off or they can be wrong for other party members, but are OK for us. - let lootIsWeapon = - not $ null $ strongestSlot IK.EqpSlotWeapon floorAssocs - return $ lootIsWeapon -- keep it lazy + let lootIsWeapon = any (isMeleeEqp . snd) floorAssocs + return lootIsWeapon -- keep it lazy -- | Check whether the actor has no weapon in equipment. condNoEqpWeaponM :: MonadClient m => ActorId -> m Bool condNoEqpWeaponM aid = do allAssocs <- fullAssocsClient aid [CEqp] - -- We do not consider OFF weapons, because they apparently are not good. - return $ null $ strongestSlot IK.EqpSlotWeapon allAssocs + return $ all (not . isMelee . snd) allAssocs -- keep it lazy + +-- | Check whether the actor has enough gear to go look for enemies. +condEnoughGearM :: MonadClient m => ActorId -> m Bool +condEnoughGearM aid = do + eqpAssocs <- fullAssocsClient aid [CEqp] + invAssocs <- fullAssocsClient aid [CInv] + return $ any (isMelee . snd) eqpAssocs + || length (eqpAssocs ++ invAssocs) >= 5 -- keep it lazy -- | Require that the actor can project any items. -condCanProjectM :: MonadClient m => ActorId -> m Bool -condCanProjectM aid = do - actorSk <- actorSkillsClient aid +condCanProjectM :: MonadClient m => Bool -> ActorId -> m Bool +condCanProjectM maxSkills aid = do + actorSk <- if maxSkills + then do + activeItems <- activeItemsClient aid + return $! sumSkills activeItems + else + actorSkillsClient aid let skill = EM.findWithDefault 0 Ability.AbProject actorSk q _ itemFull b activeItems = either (const False) id @@ -164,12 +207,20 @@ b <- getsState $ getActorBody aid activeItems <- activeItemsClient aid fact <- getsState $ (EM.! bfid b) . sfactionD + condAnyFoeAdj <- condAnyFoeAdjM aid + condLightBetrays <- condLightBetraysM aid + condTgtEnemyPresent <- condTgtEnemyPresentM aid + condNotCalmEnough <- condNotCalmEnoughM aid let ben cstore bag = [ ((benefit, (k, cstore)), (iid, itemFull)) | (iid, kit@(k, _)) <- EM.assocs bag , let itemFull = itemToF iid kit - , let benefit = totalUsefulness cops b activeItems fact itemFull - , permitted (fst <$> benefit) itemFull b activeItems ] + benefit = totalUsefulness cops b activeItems fact itemFull + hind = hinders condAnyFoeAdj condLightBetrays + condTgtEnemyPresent condNotCalmEnough + b activeItems itemFull + , permitted (fst <$> benefit) itemFull b activeItems + && (cstore /= CEqp || hind) ] benCStore cs = do bag <- getsState $ getActorBag aid cs return $! ben cs bag @@ -177,6 +228,37 @@ return $ concat perBag -- keep it lazy +-- TODO: also take into account dynamic lights *not* wielded by the actor +hinders :: Bool -> Bool -> Bool -> Bool -> Actor -> [ItemFull] -> ItemFull + -> Bool +hinders condAnyFoeAdj condLightBetrays condTgtEnemyPresent + condNotCalmEnough -- perhaps enemies don't have projectiles + body activeItems itemFull = + let itemLit = isJust $ strengthFromEqpSlot IK.EqpSlotAddLight itemFull + in -- Fast actors want to hide in darkness to ambush opponents and want + -- to hit hard for the short span they get to survive melee. + bspeed body activeItems > speedNormal + && (condNotCalmEnough && itemLit + || 0 > fromMaybe 0 (strengthFromEqpSlot IK.EqpSlotAddHurtMelee + itemFull) + || 0 > fromMaybe 0 (strengthFromEqpSlot IK.EqpSlotAddHurtRanged + itemFull)) + -- In the presence of enemies (seen, or unseen but distressing) + -- actors want to hide in the dark. + || let heavilyDistressed = -- actor hit by a proj or similarly distressed + deltaSerious (bcalmDelta body) + in condNotCalmEnough + && (heavilyDistressed || condTgtEnemyPresent) + && condLightBetrays && not condAnyFoeAdj + && itemLit + -- TODO: + -- teach AI to turn shields OFF (or stash) when ganging up on an enemy + -- (friends close, only one enemy close) + -- and turning on afterwards (AI plays for time, especially spawners + -- so shields are preferable by default; + -- also, turning on when no friends and enemies close is too late, + -- AI should flee or fire at such times, not muck around with eqp) + -- | Require the actor is not calm enough. condNotCalmEnoughM :: MonadClient m => ActorId -> m Bool condNotCalmEnoughM aid = do @@ -199,35 +281,73 @@ benGroundItems aid = do b <- getsState $ getActorBody aid canEscape <- factionCanEscape (bfid b) - let -- A hack to prevent monsters from picking up treasure. - preciousWithoutSlot item = - IK.Precious `elem` jfeature item -- risk from treasure hunters - && isNothing (strengthEqpSlot item) -- unlikely to be useful - desirableItem use ItemFull{itemBase} _ _ - | canEscape = use /= Just 0 - || IK.Precious `elem` jfeature itemBase - | otherwise = use /= Just 0 - && not (isNothing use -- needs resources to id - && preciousWithoutSlot itemBase) - benAvailableItems aid desirableItem [CGround] + benAvailableItems aid (\use itemFull _ _ -> + desirableItem canEscape use itemFull) [CGround] +desirableItem :: Bool -> Maybe Int -> ItemFull -> Bool +desirableItem canEsc use itemFull = + let item = itemBase itemFull + freq = case itemDisco itemFull of + Nothing -> [] + Just ItemDisco{itemKind} -> IK.ifreq itemKind + in if canEsc + then use /= Just 0 + || IK.Precious `elem` jfeature item + else + -- A hack to prevent monsters from picking up unidentified treasure. + let preciousWithoutSlot = + IK.Precious `elem` jfeature item -- risk from treasure hunters + && isNothing (strengthEqpSlot item) -- unlikely to be useful + in use /= Just 0 + && not (isNothing use -- needs resources to id + && preciousWithoutSlot) + -- TODO: terrible hack for the identified healing gems and normal + -- gems identified with a scroll + && maybe True (<= 0) (lookup "gem" freq) + -- | Require the actor is in a bad position to melee or can't melee at all. condMeleeBadM :: MonadClient m => ActorId -> m Bool condMeleeBadM aid = do b <- getsState $ getActorBody aid + btarget <- getsClient $ getTarget aid + mtgtPos <- aidTgtToPos aid (blid b) btarget + condTgtEnemyPresent <- condTgtEnemyPresentM aid + condTgtEnemyRemembered <- condTgtEnemyRememberedM aid fact <- getsState $ (EM.! bfid b) . sfactionD - condNoUsableWeapon <- null <$> pickWeaponClient aid aid - let friendlyFid fid = fid == bfid b || isAllied fact fid + activeItems <- activeItemsClient aid + let condNoUsableWeapon = all (not . isMelee) activeItems + friendlyFid fid = fid == bfid b || isAllied fact fid friends <- getsState $ actorRegularAssocs friendlyFid (blid b) - let closeEnough b2 = let dist = chessDist (bpos b) (bpos b2) - in dist < 3 && dist > 0 + friendlyFacts <- + getsState $ map snd . filter (friendlyFid . fst) . EM.assocs . sfactionD + Level{lactorFreq} <- getLevel $ blid b + let freqNames = map fst lactorFreq + factNames = map (fgroup . gplayer) friendlyFacts + spawnerOnLvl = any (`elem` freqNames) factNames + closeEnough b2 = let dist = chessDist (bpos b) (bpos b2) + in dist > 0 && (dist <= 2 || approaching b2) + -- 3 is the condThreatAtHand distance that AI keeps when alone. + approaching = case mtgtPos of + Just tgtPos | condTgtEnemyPresent || condTgtEnemyRemembered -> + \b1 -> chessDist (bpos b1) tgtPos <= 3 + _ -> const False closeFriends = filter (closeEnough . snd) friends strongActor (aid2, b2) = do - activeItems <- activeItemsClient aid2 - return $! not $ hpTooLow b2 activeItems + activeItems2 <- activeItemsClient aid2 + let condUsableWeapon2 = any isMelee activeItems2 + actorMaxSk2 = sumSkills activeItems2 + canMelee2 = EM.findWithDefault 0 Ability.AbMelee actorMaxSk2 > 0 + hpGood = not $ hpTooLow b2 activeItems2 + return $! hpGood && condUsableWeapon2 && canMelee2 strongCloseFriends <- filterM strongActor closeFriends - let noFriendlyHelp = length closeFriends < 3 && null strongCloseFriends + let noFriendlyHelp = length closeFriends < 3 + && null strongCloseFriends + && (length friends > 1 -- solo fighters aggresive + || spawnerOnLvl) + && not (hpHuge b) -- uniques, etc., aggresive + let actorMaxSk = sumSkills activeItems return $ condNoUsableWeapon + || EM.findWithDefault 0 Ability.AbMelee actorMaxSk <= 0 || noFriendlyHelp -- still not getting friends' help -- no $!; keep it lazy @@ -238,16 +358,18 @@ b <- getsState $ getActorBody aid eqpItems <- map snd <$> fullAssocsClient aid [CEqp] let actorEqpShines = sumSlotNoFilter IK.EqpSlotAddLight eqpItems > 0 - aInAmbient<- getsState $ actorInAmbient b + aInAmbient <- getsState $ actorInAmbient b return $! not aInAmbient -- tile is dark, so actor could hide && actorEqpShines -- but actor betrayed by his equipped light -- | Produce a list of acceptable adjacent points to flee to. -fleeList :: MonadClient m => Bool -> ActorId -> m [(Int, Point)] -fleeList panic aid = do +fleeList :: MonadClient m => ActorId -> m ([(Int, Point)], [(Int, Point)]) +fleeList aid = do cops <- getsState scops mtgtMPath <- getsClient $ EM.lookup aid . stargetD let tgtPath = case mtgtMPath of -- prefer fleeing along the path to target + Just (TEnemy{}, _) -> [] -- don't flee towards an enemy + Just (TEnemyPos{}, _) -> [] Just (_, Just (_ : path, _)) -> path _ -> [] b <- getsState $ getActorBody aid @@ -261,15 +383,15 @@ | otherwise = minimum $ map (chessDist p) posFoes dVic = map (dist &&& id) myVic -- Flee, if possible. Access required. - accVic = filter (accessibleHere . snd) $ dVic + accVic = filter (accessibleHere . snd) dVic gtVic = filter ((> dist (bpos b)) . fst) accVic - -- At least don't get closer to enemies, but don't stay adjacent. - eqVic = filter (\(d, _) -> d == dist (bpos b) && d > 1) accVic - rewardPath (d, p) = - if p `elem` tgtPath then Just (9 * d, p) - else if any (\q -> chessDist p q == 1) tgtPath then Just (d, p) - else Nothing - goodVic = mapMaybe rewardPath gtVic - ++ filter ((`elem` tgtPath) . snd) eqVic - pathVic = goodVic ++ if panic then accVic \\ goodVic else [] - return pathVic -- keep it lazy, until other conditions verify danger + eqVic = filter ((== dist (bpos b)) . fst) accVic + ltVic = filter ((< dist (bpos b)) . fst) accVic + rewardPath mult (d, p) + | p `elem` tgtPath = (100 * mult * d, p) + | any (\q -> chessDist p q == 1) tgtPath = (10 * mult * d, p) + | otherwise = (mult * d, p) + goodVic = map (rewardPath 10000) gtVic + ++ map (rewardPath 100) eqVic + badVic = map (rewardPath 1) ltVic + return (goodVic, badVic) -- keep it lazy diff --git a/Game/LambdaHack/Client/AI/HandleAbilityClient.hs b/Game/LambdaHack/Client/AI/HandleAbilityClient.hs --- a/Game/LambdaHack/Client/AI/HandleAbilityClient.hs +++ b/Game/LambdaHack/Client/AI/HandleAbilityClient.hs @@ -46,7 +46,6 @@ import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Content.TileKind as TK type ToAny a = Strategy (RequestTimed a) -> Strategy RequestAnyAbility @@ -59,49 +58,60 @@ actionStrategy :: forall m. MonadClient m => ActorId -> m (Strategy RequestAnyAbility) actionStrategy aid = do - Kind.COps{corule} <- getsState scops - let stdRuleset = Kind.stdRuleset corule - nearby = rnearby stdRuleset body <- getsState $ getActorBody aid activeItems <- activeItemsClient aid fact <- getsState $ (EM.! bfid body) . sfactionD condTgtEnemyPresent <- condTgtEnemyPresentM aid condTgtEnemyRemembered <- condTgtEnemyRememberedM aid + condTgtEnemyAdjFriend <- condTgtEnemyAdjFriendM aid condAnyFoeAdj <- condAnyFoeAdjM aid threatDistL <- threatDistList aid condHpTooLow <- condHpTooLowM aid condOnTriggerable <- condOnTriggerableM aid condBlocksFriends <- condBlocksFriendsM aid condNoEqpWeapon <- condNoEqpWeaponM aid - condNoUsableWeapon <- null <$> pickWeaponClient aid aid + let condNoUsableWeapon = all (not . isMelee) activeItems + condEnoughGear <- condEnoughGearM aid condFloorWeapon <- condFloorWeaponM aid - condCanProject <- condCanProjectM aid + condCanProject <- condCanProjectM False aid condNotCalmEnough <- condNotCalmEnoughM aid condDesirableFloorItem <- condDesirableFloorItemM aid condMeleeBad <- condMeleeBadM aid - fleeL <- fleeList False aid - panicFleeL <- fleeList True aid - let condThreatAdj = not $ null $ takeWhile ((== 1) . fst) threatDistL + condTgtNonmoving <- condTgtNonmovingM aid + aInAmbient <- getsState $ actorInAmbient body + explored <- getsClient sexplored + (fleeL, badVic) <- fleeList aid + let lidExplored = ES.member (blid body) explored + panicFleeL = fleeL ++ badVic + actorShines = sumSlotNoFilter IK.EqpSlotAddLight activeItems > 0 + condThreatAdj = not $ null $ takeWhile ((== 1) . fst) threatDistL condThreatAtHand = not $ null $ takeWhile ((<= 2) . fst) threatDistL - condThreatNearby = not $ null $ takeWhile ((<= nearby) . fst) threatDistL + condThreatNearby = not $ null $ takeWhile ((<= 9) . fst) threatDistL speed1_5 = speedScale (3%2) (bspeed body activeItems) condFastThreatAdj = any (\(_, (_, b)) -> bspeed b activeItems > speed1_5) $ takeWhile ((== 1) . fst) threatDistL - condCanFlee = not (null fleeL || condFastThreatAdj) - actorSk <- actorSkillsClient aid - let stratToFreq :: MonadStateRead m + heavilyDistressed = -- actor hit by a proj or similarly distressed + deltaSerious (bcalmDelta body) + let actorMaxSk = sumSkills activeItems + abInMaxSkill ab = EM.findWithDefault 0 ab actorMaxSk > 0 + stratToFreq :: MonadStateRead m => Int -> m (Strategy RequestAnyAbility) -> m (Frequency RequestAnyAbility) stratToFreq scale mstrat = do st <- mstrat - return $! scaleFreq scale $ bestVariant st -- TODO: flatten instead? + return $! if scale == 0 + then mzero + else scaleFreq scale $ bestVariant st -- TODO: flatten instead? + -- Order matters within the list, because it's summed with .| after + -- filtering. Also, the results of prefix, distant and suffix + -- are summed with .| at the end. prefix, suffix :: [([Ability], m (Strategy RequestAnyAbility), Bool)] prefix = - [ ( [AbApply], (toAny :: ToAny AbApply) + [ ( [AbApply], (toAny :: ToAny 'AbApply) <$> applyItem aid ApplyFirstAid , condHpTooLow && not condAnyFoeAdj && not condOnTriggerable ) -- don't block stairs, perhaps ascend - , ( [AbTrigger], (toAny :: ToAny AbTrigger) + , ( [AbTrigger], (toAny :: ToAny 'AbTrigger) <$> trigger aid True -- flee via stairs, even if to wrong level -- may return via different stairs @@ -109,238 +119,320 @@ && ((condNotCalmEnough || condHpTooLow) && condThreatNearby && not condTgtEnemyPresent || condMeleeBad && condThreatAdj) ) - , ( [AbMove] - , flee aid fleeL - , condMeleeBad && condThreatAdj && condCanFlee ) , ( [AbDisplace] , displaceFoe aid -- only swap with an enemy to expose him , condBlocksFriends && condAnyFoeAdj && not condOnTriggerable && not condDesirableFloorItem ) - , ( [AbMoveItem], (toAny :: ToAny AbMoveItem) + , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem) <$> pickup aid True - , condNoEqpWeapon && condFloorWeapon && not condHpTooLow ) - , ( [AbMelee], (toAny :: ToAny AbMelee) + , condNoEqpWeapon && condFloorWeapon && not condHpTooLow + && abInMaxSkill AbMelee ) + , ( [AbMelee], (toAny :: ToAny 'AbMelee) <$> meleeBlocker aid -- only melee target or blocker , condAnyFoeAdj - || EM.findWithDefault 0 AbDisplace actorSk <= 0 - -- melee friends, not displace + || not (abInMaxSkill AbDisplace) -- melee friends, not displace && fleaderMode (gplayer fact) == LeaderNull -- not restrained - && (condTgtEnemyPresent || condTgtEnemyRemembered) ) -- excited - , ( [AbTrigger], (toAny :: ToAny AbTrigger) + && condTgtEnemyPresent ) -- excited + , ( [AbTrigger], (toAny :: ToAny 'AbTrigger) <$> trigger aid False - , condOnTriggerable && not condDesirableFloorItem ) + , condOnTriggerable && not condDesirableFloorItem + && (lidExplored || condEnoughGear) + && not condTgtEnemyPresent ) + , ( [AbMove] + , flee aid fleeL + , condMeleeBad && not condFastThreatAdj + -- Don't keep fleeing if was just hit, unless can't melee at all. + && not (heavilyDistressed + && abInMaxSkill AbMelee + && not condNoUsableWeapon) + && condThreatAtHand ) , ( [AbDisplace] -- prevents some looping movement , displaceBlocker aid -- fires up only when path blocked , not condDesirableFloorItem ) - , ( [AbMoveItem], (toAny :: ToAny AbMoveItem) + , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem) <$> equipItems aid -- doesn't take long, very useful if safe -- only if calm enough, so high priority - , not condAnyFoeAdj && not condDesirableFloorItem ) ] + , not (condAnyFoeAdj + || condDesirableFloorItem + || condNotCalmEnough) ) + ] + -- Order doesn't matter, scaling does. distant :: [([Ability], m (Frequency RequestAnyAbility), Bool)] distant = - [ ( [AbProject] -- for high-value target, shoot even in melee - , stratToFreq 2 $ (toAny :: ToAny AbProject) + [ ( [AbMoveItem] + , stratToFreq 20000 $ (toAny :: ToAny 'AbMoveItem) + <$> yieldUnneeded aid -- 20000 to unequip ASAP, unless is thrown + , True ) + , ( [AbProject] -- for high-value target, shoot even in melee + , stratToFreq 2 $ (toAny :: ToAny 'AbProject) <$> projectItem aid , condTgtEnemyPresent && condCanProject && not condOnTriggerable ) , ( [AbApply] - , stratToFreq 2 $ (toAny :: ToAny AbApply) - <$> applyItem aid ApplyAll -- use any option or scroll + , stratToFreq 2 $ (toAny :: ToAny 'AbApply) + <$> applyItem aid ApplyAll -- use any potion or scroll , (condTgtEnemyPresent || condThreatNearby) -- can affect enemies && not condOnTriggerable ) , ( [AbMove] - , stratToFreq (if not condTgtEnemyPresent || condMeleeBad - then 1 + , stratToFreq (if not condTgtEnemyPresent + then 3 -- if enemy only remembered, investigate anyway + else if condTgtNonmoving + then 0 + else if condTgtEnemyAdjFriend + then 1000 -- friends probably pummeled, go to help else 100) - $ chase aid True + $ chase aid True (condMeleeBad && condThreatNearby + && not aInAmbient && not actorShines) , (condTgtEnemyPresent || condTgtEnemyRemembered) - && not condDesirableFloorItem - && not condNoUsableWeapon ) ] + && not (condDesirableFloorItem && not condThreatAtHand) + && abInMaxSkill AbMelee + && not condNoUsableWeapon ) + ] + -- Order matters again. suffix = - [ ( [AbMoveItem], (toAny :: ToAny AbMoveItem) - <$> pickup aid False - , True ) -- unconditionally, e.g., to give to other party members - , ( [AbMove] - , flee aid fleeL - , condMeleeBad && (condNotCalmEnough && condThreatNearby - || condThreatAtHand) - && condCanFlee ) - , ( [AbMelee], (toAny :: ToAny AbMelee) + [ ( [AbMelee], (toAny :: ToAny 'AbMelee) <$> meleeAny aid -- avoid getting damaged for naught , condAnyFoeAdj ) , ( [AbMove] - -- TODO: forget old target (e.g., tile), to start shooting, - -- unless can't shoot, etc. - , flee aid panicFleeL -- panic mode; chasing would be pointless - , condMeleeBad && condThreatNearby && (condNotCalmEnough - || condThreatAtHand - || condNoUsableWeapon) ) - , ( [AbMoveItem], (toAny :: ToAny AbMoveItem) - <$> unEquipItems aid -- late, because better to throw than unequip + , flee aid panicFleeL -- ultimate panic mode, displaces foes + , condAnyFoeAdj ) + , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem) + <$> pickup aid False + , not condThreatAtHand ) -- e.g., to give to other party members + , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem) + <$> unEquipItems aid -- late, because these items not bad , True ) , ( [AbMove] - , chase aid False - , True ) - , ( [AbWait], (toAny :: ToAny AbWait) + , chase aid True (condTgtEnemyPresent + -- Don't keep hiding in darkness if hit right now, + -- unless can't melee at all. + && not (heavilyDistressed + && abInMaxSkill AbMelee + && not condNoUsableWeapon) + && condMeleeBad && condThreatNearby + && not aInAmbient && not actorShines) + , not (condTgtNonmoving && condThreatAtHand) ) + + -- TODO: unless tgt can't melee + ] + fallback = + [ ( [AbWait], (toAny :: ToAny 'AbWait) <$> waitBlockNow -- Wait until friends sidestep; ensures strategy is never empty. -- TODO: try to switch leader away before that (we already -- switch him afterwards) - , True ) ] + , True ) + ] -- TODO: don't msum not to evaluate until needed - abInSkill ab = EM.findWithDefault 0 ab actorSk > 0 + -- Check current, not maximal skills, since this can be a non-leader action. + actorSk <- actorSkillsClient aid + let abInSkill ab = EM.findWithDefault 0 ab actorSk > 0 checkAction :: ([Ability], m a, Bool) -> Bool - checkAction (abts, _, cond) = cond && all abInSkill abts + checkAction (abts, _, cond) = all abInSkill abts && cond sumS abAction = do let as = filter checkAction abAction - strats <- sequence $ map (\(_, m, _) -> m) as + strats <- mapM (\(_, m, _) -> m) as return $! msum strats sumF abFreq = do let as = filter checkAction abFreq - strats <- sequence $ map (\(_, m, _) -> m) as + strats <- mapM (\(_, m, _) -> m) as return $! msum strats - combineDistant as = fmap liftFrequency $ sumF as + combineDistant as = liftFrequency <$> sumF as sumPrefix <- sumS prefix comDistant <- combineDistant distant sumSuffix <- sumS suffix - return $! sumPrefix .| comDistant .| sumSuffix + sumFallback <- sumS fallback + return $! sumPrefix .| comDistant .| sumSuffix .| sumFallback -- | A strategy to always just wait. -waitBlockNow :: MonadClient m => m (Strategy (RequestTimed AbWait)) +waitBlockNow :: MonadClient m => m (Strategy (RequestTimed 'AbWait)) waitBlockNow = return $! returN "wait" ReqWait pickup :: MonadClient m - => ActorId -> Bool -> m (Strategy (RequestTimed AbMoveItem)) + => ActorId -> Bool -> m (Strategy (RequestTimed 'AbMoveItem)) pickup aid onlyWeapon = do benItemL <- benGroundItems aid - let isWeapon (_, (_, itemFull)) = - maybe False ((== IK.EqpSlotWeapon) . fst) - $ strengthEqpSlot $ itemBase itemFull + b <- getsState $ getActorBody aid + activeItems <- activeItemsClient aid + -- This calmE is outdated when one of the items increases max Calm + -- (e.g., in pickup, which handles many items at once), but this is OK, + -- the server accepts item movement based on calm at the start, not end + -- or in the middle. + -- 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) + let calmE = calmEnough b activeItems + isWeapon (_, (_, itemFull)) = isMeleeEqp itemFull filterWeapon | onlyWeapon = filter isWeapon | otherwise = id - cmp ((Nothing, _), _) = 5 -- experimenting is fun - cmp ((Just (n, _), _), _) = abs n - -- Pick up the best desirable item, if any. - case reverse $ sortBy (comparing cmp) $ filterWeapon benItemL of - ((_, (k, _)), (iid, itemFull)) : _ -> do - b <- getsState $ getActorBody aid - -- TODO: instead of pickup to eqp and then move to inv, pickup to inv - let toCStore = if goesIntoInv (itemBase itemFull) - || eqpOverfull b k - then CInv - else CEqp - return $! returN "pickup" $ ReqMoveItem iid k CGround toCStore - [] -> return reject + prepareOne (oldN, l4) ((_, (k, _)), (iid, itemFull)) = + -- TODO: instead of pickup to eqp and then move to inv, pickup to inv + let n = oldN + k + (newN, toCStore) + | calmE && goesIntoSha itemFull = (oldN, CSha) + | goesIntoInv itemFull || eqpOverfull b n = (oldN, CInv) + | otherwise = (n, CEqp) + in (newN, (iid, k, CGround, toCStore) : l4) + (_, prepared) = foldl' prepareOne (0, []) $ filterWeapon benItemL + return $! if null prepared + then reject + else returN "pickup" $ ReqMoveItems prepared -equipItems :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMoveItem)) +equipItems :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) equipItems aid = do - cops@Kind.COps{corule} <- getsState scops - let RuleKind{rsharedStash} = Kind.stdRuleset corule + cops <- getsState scops body <- getsState $ getActorBody aid activeItems <- activeItemsClient aid + let calmE = calmEnough body activeItems fact <- getsState $ (EM.! bfid body) . sfactionD eqpAssocs <- fullAssocsClient aid [CEqp] invAssocs <- fullAssocsClient aid [CInv] shaAssocs <- fullAssocsClient aid [CSha] + condAnyFoeAdj <- condAnyFoeAdjM aid condLightBetrays <- condLightBetraysM aid - let improve :: CStore -> ([(Int, (ItemId, ItemFull))], - [(Int, (ItemId, ItemFull))]) - -> Strategy (RequestTimed AbMoveItem) - improve fromCStore (bestInv, bestEqp) = - case (bestInv, bestEqp) of - ((_, (iidInv, _)) : _, []) | not (eqpOverfull body 1) -> - returN "wield any" - $ ReqMoveItem iidInv 1 fromCStore CEqp - ((vInv, (iidInv, _)) : _, (vEqp, _) : _) | not (eqpOverfull body 1) - && vInv > vEqp -> - returN "wield better" - $ ReqMoveItem iidInv 1 fromCStore CEqp - _ -> reject + condTgtEnemyPresent <- condTgtEnemyPresentM aid + let improve :: CStore + -> (Int, [(ItemId, Int, CStore, CStore)]) + -> ( IK.EqpSlot + , ( [(Int, (ItemId, ItemFull))] + , [(Int, (ItemId, ItemFull))] ) ) + -> (Int, [(ItemId, Int, CStore, CStore)]) + improve fromCStore (oldN, l4) (slot, (bestInv, bestEqp)) = + let n = 1 + oldN + in case (bestInv, bestEqp) of + ((_, (iidInv, _)) : _, []) | not (eqpOverfull body n) -> + (n, (iidInv, 1, fromCStore, CEqp) : l4) + ((vInv, (iidInv, _)) : _, (vEqp, _) : _) + | not (eqpOverfull body n) + && (vInv > vEqp || not (toShare slot)) -> + (n, (iidInv, 1, fromCStore, CEqp) : l4) + _ -> (oldN, l4) -- We filter out unneeded items. In particular, we ignore them in eqp -- when comparing to items we may want to equip. Anyway, the unneeded -- items should be removed in yieldUnneeded earlier or soon after. filterNeeded (_, itemFull) = - not $ unneeded cops condLightBetrays body activeItems fact itemFull + not $ unneeded cops condAnyFoeAdj condLightBetrays + condTgtEnemyPresent (not calmE) + body activeItems fact itemFull bestThree = bestByEqpSlot (filter filterNeeded eqpAssocs) (filter filterNeeded invAssocs) (filter filterNeeded shaAssocs) - bEqpInv = msum $ map (improve CInv) - $ map (\(_, (eqp, inv, _)) -> (inv, eqp)) bestThree - bEqpSha = msum $ map (improve CSha) - $ map (\(_, (eqp, _, sha)) -> (sha, eqp)) bestThree - if nullStrategy bEqpInv - then if rsharedStash && calmEnough body activeItems - then return $! bEqpSha - else return reject - else return $! bEqpInv + bEqpInv = foldl' (improve CInv) (0, []) + $ map (\((slot, _), (eqp, inv, _)) -> + (slot, (inv, eqp))) bestThree + bEqpBoth | calmE = + foldl' (improve CSha) bEqpInv + $ map (\((slot, _), (eqp, _, sha)) -> + (slot, (sha, eqp))) bestThree + | otherwise = bEqpInv + (_, prepared) = bEqpBoth + return $! if null prepared + then reject + else returN "equipItems" $ ReqMoveItems prepared +toShare :: IK.EqpSlot -> Bool +toShare IK.EqpSlotPeriodic = False +toShare _ = True + +yieldUnneeded :: MonadClient m + => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) +yieldUnneeded aid = do + cops <- getsState scops + body <- getsState $ getActorBody aid + activeItems <- activeItemsClient aid + let calmE = calmEnough body activeItems + fact <- getsState $ (EM.! bfid body) . sfactionD + eqpAssocs <- fullAssocsClient aid [CEqp] + condAnyFoeAdj <- condAnyFoeAdjM aid + condLightBetrays <- condLightBetraysM aid + condTgtEnemyPresent <- condTgtEnemyPresentM aid + -- Here AI hides from the human player the Ring of Speed And Bleeding, + -- which is a bit harsh, but fair. However any subsequent such + -- rings will not be picked up at all, so the human player + -- doesn't lose much fun. Additionally, if AI learns alchemy later on, + -- they can repair the ring, wield it, drop at death and it's + -- in play again. + let yieldSingleUnneeded (iidEqp, itemEqp) = + let csha = if calmE then CSha else CInv + in if harmful cops body activeItems fact itemEqp + then [(iidEqp, itemK itemEqp, CEqp, CInv)] + else if hinders condAnyFoeAdj condLightBetrays + condTgtEnemyPresent (not calmE) + body activeItems itemEqp + then [(iidEqp, itemK itemEqp, CEqp, csha)] + else [] + yieldAllUnneeded = concatMap yieldSingleUnneeded eqpAssocs + return $! if null yieldAllUnneeded + then reject + else returN "yieldUnneeded" $ ReqMoveItems yieldAllUnneeded + unEquipItems :: MonadClient m - => ActorId -> m (Strategy (RequestTimed AbMoveItem)) + => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) unEquipItems aid = do - cops@Kind.COps{corule} <- getsState scops - let RuleKind{rsharedStash} = Kind.stdRuleset corule + cops <- getsState scops body <- getsState $ getActorBody aid activeItems <- activeItemsClient aid + let calmE = calmEnough body activeItems fact <- getsState $ (EM.! bfid body) . sfactionD eqpAssocs <- fullAssocsClient aid [CEqp] invAssocs <- fullAssocsClient aid [CInv] shaAssocs <- fullAssocsClient aid [CSha] + condAnyFoeAdj <- condAnyFoeAdjM aid condLightBetrays <- condLightBetraysM aid - let yieldSingleUnneeded (iidEqp, itemEqp) = - let csha = if rsharedStash && calmEnough body activeItems - then CSha - else CInv - in if harmful cops body activeItems fact itemEqp - then Just $ ReqMoveItem iidEqp (itemK itemEqp) CEqp CInv -- throw - else if hinders condLightBetrays body activeItems itemEqp - then Just $ ReqMoveItem iidEqp (itemK itemEqp) CEqp csha -- share - else Nothing - yieldUnneeded = mapMaybe yieldSingleUnneeded eqpAssocs - improve :: CStore -> ( IK.EqpSlot + condTgtEnemyPresent <- condTgtEnemyPresentM aid + -- Here AI hides from the human player the Ring of Speed And Bleeding, + -- which is a bit harsh, but fair. However any subsequent such + -- rings will not be picked up at all, so the human player + -- doesn't lose much fun. Additionally, if AI learns alchemy later on, + -- they can repair the ring, wield it, drop at death and it's + -- in play again. + let improve :: CStore -> ( IK.EqpSlot , ( [(Int, (ItemId, ItemFull))] , [(Int, (ItemId, ItemFull))] ) ) - -> Strategy (RequestTimed AbMoveItem) - improve fromCStore (slot, (bestInv, bestEqp)) = - case (bestInv, bestEqp) of - _ | slot == IK.EqpSlotPeriodic + -> [(ItemId, Int, CStore, CStore)] + improve fromCStore (slot, (bestSha, bestEOrI)) = + case (bestSha, bestEOrI) of + _ | not (toShare slot) && fromCStore == CEqp - && not (eqpOverfull body 0) -> - -- Don't get rid of periodic items from eqp unless eqp full. - reject - (_, (vEqp, (iidEqp, _)) : _) | getK bestEqp > 1 - && betterThanInv vEqp bestInv -> + && not (eqpOverfull body 1) -> -- keep periodic items up to M-1 + [] + (_, (vEOrI, (iidEOrI, _)) : _) | (toShare slot || fromCStore == CInv) + && getK bestEOrI > 1 + && betterThanSha vEOrI bestSha -> -- To share the best items with others, if they care. - returN "yield rest" - $ ReqMoveItem iidEqp (getK bestEqp - 1) fromCStore CSha - (_, _ : (vEqp, (iidEqp, _)) : _) | betterThanInv vEqp bestInv -> + [(iidEOrI, getK bestEOrI - 1, fromCStore, CSha)] + (_, _ : (vEOrI, (iidEOrI, _)) : _) | (toShare slot + || fromCStore == CInv) + && betterThanSha vEOrI bestSha -> -- To share the second best items with others, if they care. - returN "yield worse" - $ ReqMoveItem iidEqp (getK bestEqp) fromCStore CSha - _ -> reject + [(iidEOrI, getK bestEOrI, fromCStore, CSha)] + (_, (vEOrI, (_, _)) : _) | fromCStore == CEqp + && eqpOverfull body 1 + && worseThanSha vEOrI bestSha -> + -- To make place in eqp for an item better than any ours. + [(fst $ snd $ last bestEOrI, 1, fromCStore, CSha)] + _ -> [] getK [] = 0 getK ((_, (_, itemFull)) : _) = itemK itemFull - betterThanInv _ [] = True - betterThanInv vEqp ((vInv, _) : _) = vEqp > vInv - bestThree = bestByEqpSlot eqpAssocs invAssocs shaAssocs - bInvSha = msum $ map (improve CInv) + betterThanSha _ [] = True + betterThanSha vEOrI ((vSha, _) : _) = vEOrI > vSha + worseThanSha _ [] = False + worseThanSha vEOrI ((vSha, _) : _) = vEOrI < vSha + filterNeeded (_, itemFull) = + not $ unneeded cops condAnyFoeAdj condLightBetrays + condTgtEnemyPresent (not calmE) + body activeItems fact itemFull + bestThree = + bestByEqpSlot eqpAssocs invAssocs (filter filterNeeded shaAssocs) + bInvSha = concatMap (improve CInv) $ map (\((slot, _), (_, inv, sha)) -> (slot, (sha, inv))) bestThree - bEqpSha = msum $ map (improve CEqp) + bEqpSha = concatMap (improve CEqp) $ map (\((slot, _), (eqp, _, sha)) -> (slot, (sha, eqp))) bestThree - case yieldUnneeded of - [] -> if rsharedStash && calmEnough body activeItems - then if nullStrategy bInvSha - then return $! bEqpSha - else return $! bInvSha - else return reject - _ -> - -- Here AI hides from the human player the Ring of Speed And Bleeding, - -- which is a bit harsh, but fair. However any subsequent such - -- rings will not be picked up at all, so the human player - -- doesn't lose much fun. Additionally, if AI learns alchemy later on, - -- they can repair the ring, wield it, drop at death and it's - -- in play again. - return $! liftFrequency $ uniformFreq "yield unneeded" yieldUnneeded + prepared = if calmE then bInvSha ++ bEqpSha else [] + return $! if null prepared + then reject + else returN "unEquipItems" $ ReqMoveItems prepared groupByEqpSlot :: [(ItemId, ItemFull)] -> M.Map (IK.EqpSlot, Text) [(ItemId, ItemFull)] @@ -364,35 +456,12 @@ shaMap = M.map (\g -> ([], [], g)) $ groupByEqpSlot shaAssocs appendThree (g1, g2, g3) (h1, h2, h3) = (g1 ++ h1, g2 ++ h2, g3 ++ h3) eqpInvShaMap = M.unionsWith appendThree [eqpMap, invMap, shaMap] - bestSingle eqpSlot g = strongestSlot eqpSlot g + bestSingle = strongestSlot bestThree (eqpSlot, _) (g1, g2, g3) = (bestSingle eqpSlot g1, bestSingle eqpSlot g2, bestSingle eqpSlot g3) in M.assocs $ M.mapWithKey bestThree eqpInvShaMap -hinders :: Bool -> Actor -> [ItemFull] -> ItemFull -> Bool -hinders condLightBetrays body activeItems itemFull = - -- Fast actors want to hide in darkness to ambush opponents and want - -- to hit hard for the short span they get to survive melee. - (bspeed body activeItems > speedNormal - && (isJust (strengthFromEqpSlot IK.EqpSlotAddLight itemFull) - || 0 > fromMaybe 0 (strengthFromEqpSlot IK.EqpSlotAddHurtMelee - itemFull) - || 0 > fromMaybe 0 (strengthFromEqpSlot IK.EqpSlotAddHurtRanged - itemFull))) - -- Distressed actors want to hide in the dark. - || (let heavilyDistressed = -- actor hit by a proj or similarly distressed - deltaSerious (bcalmDelta body) - in condLightBetrays && heavilyDistressed - && isJust (strengthFromEqpSlot IK.EqpSlotAddLight itemFull)) - -- TODO: - -- teach AI to turn shields OFF (or stash) when ganging up on an enemy - -- (friends close, only one enemy close) - -- and turning on afterwards (AI plays for time, especially spawners - -- so shields are preferable by default; - -- also, turning on when no friends and enemies close is too late, - -- AI should flee or fire at such times, not muck around with eqp) - harmful :: Kind.COps -> Actor -> [ItemFull] -> Faction -> ItemFull -> Bool harmful cops body activeItems fact itemFull = -- Items that are known and their effects are not stricly beneficial @@ -400,14 +469,22 @@ maybe False (\(u, _) -> u <= 0) (totalUsefulness cops body activeItems fact itemFull) -unneeded :: Kind.COps -> Bool -> Actor -> [ItemFull] -> Faction -> ItemFull +unneeded :: Kind.COps -> Bool -> Bool -> Bool -> Bool + -> Actor -> [ItemFull] -> Faction -> ItemFull -> Bool -unneeded cops condLightBetrays body activeItems fact itemFull = +unneeded cops condAnyFoeAdj condLightBetrays + condTgtEnemyPresent condNotCalmEnough + body activeItems fact itemFull = harmful cops body activeItems fact itemFull - || hinders condLightBetrays body activeItems itemFull + || hinders condAnyFoeAdj condLightBetrays + condTgtEnemyPresent condNotCalmEnough + body activeItems itemFull + || let calm10 = calmEnough10 body activeItems -- unneeded risk + itemLit = isJust $ strengthFromEqpSlot IK.EqpSlotAddLight itemFull + in itemLit && not calm10 -- Everybody melees in a pinch, even though some prefer ranged attacks. -meleeBlocker :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMelee)) +meleeBlocker :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMelee)) meleeBlocker aid = do b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD @@ -417,9 +494,9 @@ Just (_, Just (_ : q : _, (goal, _))) -> do -- We prefer the goal (e.g., when no accessible, but adjacent), -- but accept @q@ even if it's only a blocking enemy position. - let maim = if adjacent (bpos b) goal then Just goal - else if adjacent (bpos b) q then Just q - else Nothing -- MeleeDistant + let maim | adjacent (bpos b) goal = Just goal + | adjacent (bpos b) q = Just q + | otherwise = Nothing -- MeleeDistant mBlocker <- case maim of Nothing -> return Nothing Just aim -> getsState $ posToActor aim (blid b) @@ -436,7 +513,7 @@ && EM.findWithDefault 0 AbMove actorSk > 0 -- blocked move && bhp body2 < bhp b) -- respect power then do - mel <- pickWeaponClient aid aid2 + mel <- maybeToList <$> pickWeaponClient aid aid2 return $! liftFrequency $ uniformFreq "melee in the way" mel else return reject Nothing -> return reject @@ -444,7 +521,7 @@ -- Everybody melees in a pinch, skills and weapons allowing, -- even though some prefer ranged attacks. -meleeAny :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMelee)) +meleeAny :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMelee)) meleeAny aid = do b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD @@ -452,13 +529,20 @@ let adjFoes = filter (adjacent (bpos b) . bpos . snd) allFoes mels <- mapM (pickWeaponClient aid . fst) adjFoes -- TODO: prioritize somehow - let freq = uniformFreq "melee adjacent" $ concat mels + let freq = uniformFreq "melee adjacent" $ catMaybes mels return $! liftFrequency freq -- TODO: take charging status into account --- Fast monsters don't pay enough attention to features. +-- TODO: make sure the stairs are specifically targetted and not +-- an item on them, etc., so that we don't leave level if items visible. +-- When invalidating target, make sure the stairs should really be taken. +-- | 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 the stairs are targeted by the actor, but at least +-- the actor doesn't target a visible enemy at this point. trigger :: MonadClient m - => ActorId -> Bool -> m (Strategy (RequestTimed AbTrigger)) + => ActorId -> Bool -> m (Strategy (RequestTimed 'AbTrigger)) trigger aid fleeViaStairs = do cops@Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops dungeon <- getsState sdungeon @@ -470,70 +554,69 @@ lvl <- getLevel lid unexploredD <- unexploredDepth s <- getState - per <- getPerFid lid - let canSee = ES.member (bpos b) (totalVisible per) - unexploredCurrent = ES.notMember lid explored + let lidExplored = ES.member lid explored allExplored = ES.size explored == EM.size dungeon t = lvl `at` bpos b feats = TK.tfeature $ okind t ben feat = case feat of - TK.Cause (IK.Ascend k) -> -- change levels sensibly, in teams - let aimless = ftactic (gplayer fact) `elem` [TRoam, TPatrol] - easeDelta = abs (fromEnum lid) - abs (fromEnum lid + k) + TK.Cause (IK.Ascend k) -> do -- change levels sensibly, in teams + (lid2, pos2) <- getsState $ whereTo lid (bpos b) k . sdungeon + per <- getPerFid lid2 + let canSee = ES.member (bpos b) (totalVisible per) + aimless = ftactic (gplayer fact) `elem` [TRoam, TPatrol] + easier = signum k /= signum (fromEnum lid) unexpForth = unexploredD (signum k) lid unexpBack = unexploredD (- signum k) lid - expBenefit = - if aimless - then 100 -- faction is not exploring, so switch at will - else if unexploredCurrent - then 0 -- don't leave the level until explored - else if unexpForth - then if easeDelta > 0 -- alway try as easy level as possible - || not unexpBack -- no other choice for exploration - then 1000 * abs easeDelta - else 0 - else if unexpBack - then 0 -- wait for stairs in the opposite direciton - else if lescape lvl - then 0 -- all explored, stay on the escape level - else 2 -- no escape anywhere, switch levels occasionally - (lid2, pos2) = whereTo lid (bpos b) k dungeon + expBenefit + | aimless = 100 -- faction is not exploring, so switch at will + | unexpForth = + if easier -- alway try as easy level as possible + || not unexpBack + && lidExplored -- no other choice for exploration + then 1000 + else 0 + | not lidExplored = 0 -- fully explore current + | unexpBack = 0 -- wait for stairs in the opposite direciton + | not $ null $ lescape lvl = 0 + -- all explored, stay on the escape level + | otherwise = 2 -- no escape, switch levels occasionally actorsThere = posToActors pos2 lid2 s - in if boldpos b == bpos b -- probably used stairs last turn + return $! + if boldpos b == bpos b -- probably used stairs last turn && boldlid b == lid2 -- in the opposite direction then 0 -- avoid trivial loops (pushing, being pushed, etc.) - else let leaderless = fleaderMode (gplayer fact) == LeaderNull - eben = case actorsThere of + else let eben = case actorsThere of [] | canSee -> expBenefit - _ | leaderless -> 0 -- leaderless clog stairs easily _ -> min 1 expBenefit -- risk pushing in if fleeViaStairs then 1000 * eben + 1 -- strongly prefer correct direction else eben - TK.Cause ef@IK.Escape{} -> do -- flee via this way, too + TK.Cause ef@IK.Escape{} -> return $ -- flee via this way, too -- Only some factions try to escape but they first explore all -- for high score. if not (fcanEscape $ gplayer fact) || not allExplored then 0 else effectToBenefit cops b activeItems fact ef TK.Cause ef | not fleeViaStairs -> - effectToBenefit cops b activeItems fact ef - _ -> 0 - benFeat = zip (map ben feats) feats + return $! effectToBenefit cops b activeItems fact ef + _ -> return 0 + benFeats <- mapM ben feats + let benFeat = zip benFeats feats return $! liftFrequency $ toFreq "trigger" - $ [ (benefit, ReqTrigger (Just feat)) - | (benefit, feat) <- benFeat - , benefit > 0 ] + [ (benefit, ReqTrigger (Just feat)) + | (benefit, feat) <- benFeat + , benefit > 0 ] -projectItem :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbProject)) +projectItem :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbProject)) projectItem aid = do btarget <- getsClient $ getTarget aid - b@Actor{bpos} <- getsState $ getActorBody aid + b <- getsState $ getActorBody aid mfpos <- aidTgtToPos aid (blid b) btarget seps <- getsClient seps case (btarget, mfpos) of + (_, Just fpos) | chessDist (bpos b) fpos == 1 -> return reject (Just TEnemy{}, Just fpos) -> do - mnewEps <- makeLine b fpos seps + mnewEps <- makeLine False b fpos seps case mnewEps of Just newEps -> do actorSk <- actorSkillsClient aid @@ -547,26 +630,23 @@ localTime <- getsState $ getLocalTime (blid b) let coeff CGround = 2 coeff COrgan = 3 -- can't give to others - coeff CEqp = 1 + coeff CEqp = 100000 -- must hinder currently coeff CInv = 1 coeff CSha = undefined -- banned - fRanged ((mben, (_, cstore)), (iid, itemFull@ItemFull{..})) = - let it1 = case strengthFromEqpSlot IK.EqpSlotTimeout - itemFull of - Nothing -> [] - Just timeout -> - let timeoutTurns = - timeDeltaScale (Delta timeTurn) timeout - pending startT = - timeShift startT timeoutTurns > localTime - in filter pending itemTimer - len = length it1 - recharged = len < itemK + fRanged ( (mben, (_, cstore)) + , (iid, itemFull@ItemFull{itemBase}) ) = + -- We assume if the item has a timeout, most effects are under + -- Recharging, so no point projecting if not recharged. + -- This is not an obvious assumption, so recharging is not + -- included in permittedProject and can be tweaked here easily. + let recharged = hasCharge localTime itemFull trange = totalRange itemBase - bestRange = chessDist bpos fpos + 2 -- margin for fleeing + bestRange = + chessDist (bpos b) fpos + 2 -- margin for fleeing rangeMult = -- penalize wasted or unsafely low range 10 + max 0 (10 - abs (trange - bestRange)) - durableBonus = if IK.Durable `elem` jfeature itemBase + durable = IK.Durable `elem` jfeature itemBase + durableBonus = if durable then 2 -- we or foes keep it after the throw else 1 benR = durableBonus @@ -575,7 +655,10 @@ Nothing -> -1 -- experiment if no options Just (_, ben) -> ben * (if recharged then 1 else 0) - in if benR < 0 && trange >= chessDist bpos fpos + in if -- Durable weapon is usually too useful for melee. + not (isMeleeEqp itemFull) + && benR < 0 + && trange >= chessDist (bpos b) fpos then Just ( -benR * rangeMult `div` 10 , ReqProject fpos newEps iid cstore ) else Nothing @@ -588,17 +671,17 @@ deriving Eq applyItem :: MonadClient m - => ActorId -> ApplyItemGroup -> m (Strategy (RequestTimed AbApply)) + => ActorId -> ApplyItemGroup -> m (Strategy (RequestTimed 'AbApply)) applyItem aid applyGroup = do actorSk <- actorSkillsClient aid + b <- getsState $ getActorBody aid + localTime <- getsState $ getLocalTime (blid b) let skill = EM.findWithDefault 0 AbProject actorSk - q _ itemFull b activeItems = + q _ itemFull _ activeItems = either (const False) id - $ permittedApply " " skill itemFull b activeItems + $ permittedApply " " localTime skill itemFull b activeItems benList <- benAvailableItems aid q [CEqp, CInv, CGround] - b <- getsState $ getActorBody aid organs <- mapM (getsState . getItemBody) $ EM.keys $ borgan b - localTime <- getsState $ getLocalTime (blid b) let itemLegal itemFull = case applyGroup of ApplyFirstAid -> let getP (IK.RefillHP p) _ | p > 0 = True @@ -611,19 +694,11 @@ ApplyAll -> True coeff CGround = 2 coeff COrgan = 3 -- can't give to others - coeff CEqp = 1 + coeff CEqp = 100000 -- must hinder currently coeff CInv = 1 coeff CSha = undefined -- banned - fTool ((mben, (_, cstore)), (iid, itemFull@ItemFull{..})) = - let it1 = case strengthFromEqpSlot IK.EqpSlotTimeout itemFull of - Nothing -> [] - Just timeout -> - let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout - pending startT = timeShift startT timeoutTurns > localTime - in filter pending itemTimer - len = length it1 - recharged = len < itemK - durableBonus = if IK.Durable `elem` jfeature itemBase + fTool ((mben, (_, cstore)), (iid, itemFull@ItemFull{itemBase})) = + let durableBonus = if IK.Durable `elem` jfeature itemBase then 5 -- we keep it after use else 1 oldGrps = map (toGroupName . jname) organs @@ -641,23 +716,20 @@ -- common and easy to drop organ, etc. let newGrps = strengthDropOrgan itemFull hasDropOrgan = not $ null newGrps - in hasDropOrgan && null (intersect newGrps oldGrps) + in hasDropOrgan && null (newGrps `intersect` oldGrps) benR = case mben of Nothing -> 0 -- experimenting is fun, but it's better to risk - -- foes' skin than ours -- TODO: when {activated} + -- foes' skin than ours -- TODO: when {applied} -- is implemented, enable this for items too heavy, -- etc. for throwing Just (_, ben) -> ben - * (if recharged then 1 else 0) -- wait until can be used * (if not createOrganAgain then 1 else 0) * (if not dropOrganVoid then 1 else 0) * durableBonus * coeff cstore - in if itemLegal itemFull - then if benR > 0 - then Just (benR, ReqApply iid cstore) - else Nothing + in if itemLegal itemFull && benR > 0 + then Just (benR, ReqApply iid cstore) else Nothing benTool = mapMaybe fTool benList return $! liftFrequency $ toFreq "applyItem" benTool @@ -684,15 +756,15 @@ let friendlyFid fid = fid == bfid b || isAllied fact fid friends <- getsState $ actorRegularList friendlyFid (blid b) allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b) - let accessibleHere = accessible cops lvl $ bpos b -- DisplaceAccess - displaceable body = -- DisplaceAccess, DisplaceDying, DisplaceSupported - accessibleHere (bpos body) - && adjacent (bpos body) (bpos b) + let accessibleHere = accessible cops lvl $ bpos b + displaceable body = -- DisplaceAccess + adjacent (bpos body) (bpos b) && accessibleHere (bpos body) nFriends body = length $ filter (adjacent (bpos body) . bpos) friends nFrHere = nFriends b + 1 qualifyActor (aid2, body2) = do activeItems <- activeItemsClient aid2 dEnemy <- getsState $ dispEnemy aid aid2 activeItems + -- DisplaceDying, DisplaceBraced, DisplaceImmobile, DisplaceSupported let nFr = nFriends body2 return $! if displaceable body2 && dEnemy && nFr < nFrHere then Just (nFr * nFr, bpos body2 `vectorToFrom` bpos b) @@ -716,7 +788,7 @@ displaceTowards aid source target = do cops <- getsState scops b <- getsState $ getActorBody aid - assert (source == bpos b && adjacent source target) skip + let !_A = assert (source == bpos b && adjacent source target) () lvl <- getLevel $ blid b if boldpos b /= target -- avoid trivial loops && accessible cops lvl source target then do -- DisplaceAccess @@ -728,10 +800,13 @@ mtgtMPath <- getsClient $ EM.lookup aid2 . stargetD case mtgtMPath of Just (tgt, Just (p : q : rest, (goal, len))) - | q == source && p == target -> do - let newTgt = Just (tgt, Just (q : rest, (goal, len - 1))) + | q == source && p == target + || waitedLastTurn b2 -> do + let newTgt = if q == source && p == target + then Just (tgt, Just (q : rest, (goal, len - 1))) + else Nothing modifyClient $ \cli -> - cli {stargetD = EM.alter (const $ newTgt) aid (stargetD cli)} + cli {stargetD = EM.alter (const newTgt) aid (stargetD cli)} return $! returN "displace friend" $ target `vectorToFrom` source Just _ -> return reject Nothing -> do @@ -740,17 +815,21 @@ dEnemy <- getsState $ dispEnemy aid aid2 activeItems if not (isAtWar tfact (bfid b)) || dEnemy then return $! returN "displace other" $ target `vectorToFrom` source - else return reject -- DisplaceDying, DisplaceSupported + else return reject -- DisplaceDying, etc. _ -> return reject -- DisplaceProjectiles or trying to displace leader else return reject -chase :: MonadClient m => ActorId -> Bool -> m (Strategy RequestAnyAbility) -chase aid doDisplace = do +chase :: MonadClient m + => ActorId -> Bool -> Bool -> m (Strategy RequestAnyAbility) +chase aid doDisplace avoidAmbient = do + Kind.COps{cotile} <- getsState scops body <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid body) . sfactionD mtgtMPath <- getsClient $ EM.lookup aid . stargetD + lvl <- getLevel $ blid body + let isAmbient pos = Tile.isLit cotile (lvl `at` pos) str <- case mtgtMPath of - Just (_, Just (p : q : _, (goal, _))) -> + Just (_, Just (p : q : _, (goal, _))) | not $ avoidAmbient && isAmbient q -> -- With no leader, the goal is vague, so permit arbitrary detours. moveTowards aid p q goal (fleaderMode (gplayer fact) == LeaderNull) _ -> return reject -- goal reached @@ -765,7 +844,10 @@ moveTowards aid source target goal relaxed = do cops@Kind.COps{cotile} <- getsState scops b <- getsState $ getActorBody aid - assert (source == bpos b && adjacent source target) skip + let !_A = assert (source == bpos b + `blame` (source, bpos b, aid, b, goal)) () + !_B = assert (adjacent source target + `blame` (source, target, aid, b, goal)) () lvl <- getLevel $ blid b fact <- getsState $ (EM.! bfid b) . sfactionD friends <- getsState $ actorList (not . isAtWar fact) $ blid b @@ -816,26 +898,26 @@ tfact <- getsState $ (EM.! bfid b2) . sfactionD activeItems <- activeItemsClient target dEnemy <- getsState $ dispEnemy source target activeItems - if boldpos sb /= tpos -- avoid trivial Displace loops - && accessible cops lvl spos tpos -- DisplaceAccess - && (not (isAtWar tfact (bfid sb)) - || dEnemy) -- DisplaceDying, DisplaceSupported - then - return $! Just $ RequestAnyAbility $ ReqDisplace target - else do + if boldpos sb == tpos && not (waitedLastTurn sb) -- avoid Displace loops + || not (accessible cops lvl spos tpos) -- DisplaceAccess + then return Nothing + else if isAtWar tfact (bfid sb) && not dEnemy -- DisplaceDying, etc. + then do wps <- pickWeaponClient source target case wps of - [] -> return Nothing - wp : _ -> return $! Just $ RequestAnyAbility wp + Nothing -> return Nothing + Just wp -> return $! Just $ RequestAnyAbility wp + else do + return $! Just $ RequestAnyAbility $ ReqDisplace target ((target, _), _) : _ -> do -- can be a foe, as well as friend (e.g., proj.) -- No problem if there are many projectiles at the spot. We just -- attack the first one. -- Attacking does not require full access, adjacency is enough. wps <- pickWeaponClient source target case wps of - [] -> return Nothing - wp : _ -> return $! Just $ RequestAnyAbility wp - [] -> do -- move or search or alter + Nothing -> return Nothing + Just wp -> return $! Just $ RequestAnyAbility wp + [] -> -- move or search or alter if accessible cops lvl spos tpos then -- Movement requires full access. return $! Just $ RequestAnyAbility $ ReqMove dir diff --git a/Game/LambdaHack/Client/AI/PickActorClient.hs b/Game/LambdaHack/Client/AI/PickActorClient.hs --- a/Game/LambdaHack/Client/AI/PickActorClient.hs +++ b/Game/LambdaHack/Client/AI/PickActorClient.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE TupleSections #-} -- | Semantics of most 'ResponseAI' client commands. module Game.LambdaHack.Client.AI.PickActorClient ( pickActorToMove ) where +import Control.Applicative +import Control.Arrow import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM @@ -12,13 +15,16 @@ import Game.LambdaHack.Client.AI.ConditionClient import Game.LambdaHack.Client.AI.PickTargetClient +import Game.LambdaHack.Client.BfsClient import Game.LambdaHack.Client.CommonClient 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.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc @@ -31,8 +37,7 @@ import Game.LambdaHack.Content.ModeKind pickActorToMove :: MonadClient m - => (ActorId -> (ActorId, Actor) - -> m (Maybe ((ActorId, Actor), (Target, PathEtc)))) + => ((ActorId, Actor) -> m (Maybe (Target, PathEtc))) -> ActorId -> m (ActorId, Actor) pickActorToMove refreshTarget oldAid = do @@ -46,7 +51,7 @@ t = lvl `at` bpos oldBody mleader <- getsClient _sleader ours <- getsState $ actorRegularAssocs (== side) arena - let explore = void $ refreshTarget oldAid (oldAid, oldBody) + let explore = void $ refreshTarget (oldAid, oldBody) pickOld = do if mleader == Just oldAid then explore else case ftactic $ gplayer fact of @@ -63,16 +68,16 @@ else do -- Copy over the leader's target, if any, or follow his bpos. tgtLeader <- do - mtgt <- getsClient $ (EM.lookup leader) . stargetD + mtgt <- getsClient $ EM.lookup leader . stargetD case mtgt of Nothing -> return $! TEnemy leader True Just (tgtLeader, _) -> return tgtLeader modifyClient $ \cli -> - cli { sbfsD = EM.delete oldAid (sbfsD cli) + cli { sbfsD = invalidateBfs oldAid (sbfsD cli) , seps = seps cli + 773 } -- randomize paths mpath <- createPath oldAid tgtLeader - let tgtMPath = maybe (tgtLeader, Nothing) - (\(tgt, p) -> (tgt, Just p)) mpath + let tgtMPath = + maybe (tgtLeader, Nothing) (second Just) mpath modifyClient $ \cli -> cli {stargetD = EM.alter (const $ Just tgtMPath) oldAid (stargetD cli)} @@ -98,25 +103,35 @@ -- the old leader, if he is among the best candidates -- (to make the AI appear more human-like and easier to observe). -- TODO: this also takes melee into account, but not shooting. - oursTgt <- fmap catMaybes $ mapM (refreshTarget oldAid) ours - let actorWeak ((aid, body), _) = do + let refresh aidBody = do + mtgt <- refreshTarget aidBody + return $! (aidBody,) <$> mtgt + oursTgt <- catMaybes <$> mapM refresh ours + let actorVulnerable ((aid, body), _) = do activeItems <- activeItemsClient aid condMeleeBad <- condMeleeBadM aid threatDistL <- threatDistList aid - fleeL <- fleeList False aid - let condThreatAdj = - not $ null $ takeWhile ((== 1) . fst) threatDistL + (fleeL, _) <- fleeList aid + let actorMaxSk = sumSkills activeItems + abInMaxSkill ab = EM.findWithDefault 0 ab actorMaxSk > 0 + condNoUsableWeapon = all (not . isMelee) activeItems + canMelee = abInMaxSkill AbMelee && not condNoUsableWeapon + condCanFlee = not (null fleeL) + condThreatAtHandVeryClose = + not $ null $ takeWhile ((<= 2) . fst) threatDistL + threatAdj = takeWhile ((== 1) . fst) threatDistL + condThreatAdj = not $ null threatAdj condFastThreatAdj = any (\(_, (_, b)) -> bspeed b activeItems > bspeed body activeItems) - $ takeWhile ((== 1) . fst) threatDistL - condCanFlee = not (null fleeL || condFastThreatAdj) + threatAdj heavilyDistressed = -- Actor hit by a projectile or similarly distressed. deltaSerious (bcalmDelta body) - return $! if condThreatAdj - then condMeleeBad && condCanFlee - else heavilyDistressed + return $! if canMelee && condThreatAdj then False + else if condThreatAtHandVeryClose + then condCanFlee && condMeleeBad && not condFastThreatAdj + else heavilyDistressed -- shot at -- TODO: modify when reaction fire is possible actorHearning (_, (TEnemyPos{}, (_, (_, d)))) | d <= 2 = return False -- noise probably due to fleeing target @@ -129,16 +144,25 @@ -- AI has to be prudent and not lightly waste leader for meleeing, -- even if his target is distant actorMeleeing ((aid, _), _) = condAnyFoeAdjM aid - oursWeak <- filterM actorWeak oursTgt - oursStrong <- filterM (fmap not . actorWeak) oursTgt -- TODO: partitionM - oursMeleeing <- filterM actorMeleeing oursStrong - oursNotMeleeing <- filterM (fmap not . actorMeleeing) oursStrong + actorMeleeBad ((aid, _), _) = do + threatDistL <- threatDistList aid + let condThreatMedium = -- if foes far, friends may still come + not $ null $ takeWhile ((<= 5) . fst) threatDistL + condMeleeBad <- condMeleeBadM aid + return $! condThreatMedium && condMeleeBad + oursVulnerable <- filterM actorVulnerable oursTgt + oursSafe <- filterM (fmap not . actorVulnerable) oursTgt + -- TODO: partitionM + oursMeleeing <- filterM actorMeleeing oursSafe + oursNotMeleeing <- filterM (fmap not . actorMeleeing) oursSafe oursHearing <- filterM actorHearning oursNotMeleeing oursNotHearing <- filterM (fmap not . actorHearning) oursNotMeleeing + oursMeleeBad <- filterM actorMeleeBad oursNotHearing + oursNotMeleeBad <- filterM (fmap not . actorMeleeBad) oursNotHearing let targetTEnemy (_, (TEnemy{}, _)) = True targetTEnemy (_, (TEnemyPos{}, _)) = True targetTEnemy _ = False - (oursTEnemy, oursOther) = partition targetTEnemy oursNotHearing + (oursTEnemy, oursOther) = partition targetTEnemy oursNotMeleeBad -- These are not necessarily stuck (perhaps can go around), -- but their current path is blocked by friends. targetBlocked our@((_aid, _b), (_tgt, (path, _etc))) = @@ -152,7 +176,8 @@ -- so far we only detect blocked and only in Other mode -- && not (aid == oldAid && waitedLastTurn b time) -- not stuck -- this only prevents staying stuck - (oursBlocked, oursPos) = partition targetBlocked oursOther + (oursBlocked, oursPos) = + partition targetBlocked $ oursOther ++ oursMeleeBad -- Lower overhead is better. overheadOurs :: ((ActorId, Actor), (Target, PathEtc)) -> (Int, Int, Bool) @@ -160,7 +185,7 @@ if targetTEnemy our then -- TODO: take weapon, walk and fight speed, etc. into account ( d + if targetBlocked our then 2 else 0 -- possible delay, hacky - , - 10 * (fromIntegral $ bhp b `div` (10 * oneM)) + , - 10 * fromIntegral (bhp b `div` (10 * oneM)) , aid /= oldAid ) else -- Keep proper formation, not too dense, not to sparse. @@ -206,13 +231,13 @@ not (adjacent (bpos b) goal) -- not in melee range already && goodGeneric our goodTEnemy our = goodGeneric our - oursWeakGood = filter goodTEnemy oursWeak + oursVulnerableGood = filter goodTEnemy oursVulnerable oursTEnemyGood = filter goodTEnemy oursTEnemy oursPosGood = filter goodGeneric oursPos oursMeleeingGood = filter goodGeneric oursMeleeing oursHearingGood = filter goodTEnemy oursHearing oursBlockedGood = filter goodGeneric oursBlocked - candidates = [ sortOurs oursWeakGood + candidates = [ sortOurs oursVulnerableGood , sortOurs oursTEnemyGood , sortOurs oursPosGood , sortOurs oursMeleeingGood diff --git a/Game/LambdaHack/Client/AI/PickTargetClient.hs b/Game/LambdaHack/Client/AI/PickTargetClient.hs --- a/Game/LambdaHack/Client/AI/PickTargetClient.hs +++ b/Game/LambdaHack/Client/AI/PickTargetClient.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} -- | Let AI pick the best target for an actor. module Game.LambdaHack.Client.AI.PickTargetClient ( targetStrategy, createPath @@ -5,8 +6,10 @@ import Control.Applicative import Control.Exception.Assert.Sugar +import Control.Monad import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES +import Data.List import Data.Maybe import Game.LambdaHack.Client.AI.ConditionClient @@ -21,7 +24,7 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level @@ -39,13 +42,13 @@ -- | AI proposes possible targets for the actor. Never empty. targetStrategy :: forall m. MonadClient m - => ActorId -> ActorId -> m (Strategy (Target, Maybe PathEtc)) -targetStrategy oldLeader aid = do + => ActorId -> m (Strategy (Target, Maybe PathEtc)) +targetStrategy aid = do cops@Kind.COps{corule, cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops let stdRuleset = Kind.stdRuleset corule nearby = rnearby stdRuleset itemToF <- itemToFullClient - modifyClient $ \cli -> cli { sbfsD = EM.delete aid (sbfsD cli) + modifyClient $ \cli -> cli { sbfsD = invalidateBfs aid (sbfsD cli) , seps = seps cli + 773 } -- randomize paths b <- getsState $ getActorBody aid activeItems <- activeItemsClient aid @@ -72,24 +75,25 @@ then Just (tgt, (q : rest, (goal, len - 1))) -- step along path else Nothing -- veered off the path ([p], (goal, _)) -> do - assert (p == goal `blame` (aid, b, mtgtMPath)) skip + let !_A = assert (p == goal `blame` (aid, b, mtgtMPath)) () if bpos b == p then Just (tgt, path) -- goal reached; stay there picking up items else Nothing -- somebody pushed us off the goal; let's target again ([], _) -> assert `failure` (aid, b, mtgtMPath) Nothing -> return Nothing -- no target assigned yet - assert (not $ bproj b) skip -- would work, but is probably a bug + let !_A = assert (not $ bproj b) () -- would work, but is probably a bug fact <- getsState $ (EM.! bfid b) . sfactionD allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b) dungeon <- getsState sdungeon - itemD <- getsState sitemD -- We assume the actor eventually becomes a leader (or has the same -- set of abilities as the leader, anyway) and set his target accordingly. - actorSk <- maxActorSkillsClient aid - condCanProject <- condCanProjectM aid - condMeleeBad <- condMeleeBadM aid + let actorMaxSk = sumSkills activeItems + actorMinSk <- getsState $ actorSkills Nothing aid activeItems + condCanProject <- condCanProjectM True aid condHpTooLow <- condHpTooLowM aid + condEnoughGear <- condEnoughGearM aid + condMeleeBad <- condMeleeBadM aid let friendlyFid fid = fid == bfid b || isAllied fact fid friends <- getsState $ actorRegularList friendlyFid (blid b) -- TODO: refine all this when some actors specialize in ranged attacks @@ -99,51 +103,72 @@ canEscape <- factionCanEscape (bfid b) explored <- getsClient sexplored smellRadius <- sumOrganEqpClient IK.EqpSlotAddSmell aid - let canSmell = smellRadius > 0 + let condNoUsableWeapon = all (not . isMelee) activeItems + lidExplored = ES.member (blid b) explored + allExplored = ES.size explored == EM.size dungeon + canSmell = smellRadius > 0 meleeNearby | canEscape = nearby `div` 2 -- not aggresive | otherwise = nearby rangedNearby = 2 * meleeNearby - targetableMelee body = - chessDist (bpos body) (bpos b) < meleeNearby - && not condMeleeBad + -- Don't target nonmoving actors at all if bad melee, + -- because nonmoving can't be lured nor ambushed. + -- This is especially important for fences, tower defense actors, etc. + -- If content gives nonmoving actor loot, this becomes problematic. + targetableMelee aidE body = do + activeItemsE <- activeItemsClient aidE + let actorMaxSkE = sumSkills activeItemsE + attacksFriends = any (adjacent (bpos body) . bpos) friends + n = if attacksFriends then rangedNearby else meleeNearby + nonmoving = EM.findWithDefault 0 AbMove actorMaxSkE <= 0 + return {-keep lazy-} $ + chessDist (bpos body) (bpos b) < n + && not condNoUsableWeapon + && EM.findWithDefault 0 AbMelee actorMaxSk > 0 + && not (hpTooLow b activeItems) + && not (nonmoving && condMeleeBad) targetableRangedOrSpecial body = chessDist (bpos body) (bpos b) < rangedNearby - && (condCanProject - || hpTooLow body activeItems -- easy prey - || any (adjacent (bpos body) . bpos) friends) -- attacks friends! - targetableEnemy body = - targetableMelee body || targetableRangedOrSpecial body - nearbyFoes = filter (targetableEnemy . snd) allFoes - unknownId = ouniqGroup "unknown space" - itemUsefulness iid k = - fst <$> totalUsefulness cops b activeItems fact (itemToF iid k) - -- TODO: factor out from here and benGroundItems - desirableItem iid item k - | canEscape = itemUsefulness iid k /= Just 0 - || IK.Precious `elem` jfeature item - | otherwise = - let use = itemUsefulness iid k - -- A hack to prevent monsters from picking up treasure. - preciousWithoutSlot item2 = - IK.Precious `elem` jfeature item2 -- risk from treasure hunters - && isNothing (strengthEqpSlot item2) -- unlikely to be useful - in use /= Just 0 - && not (isNothing use -- needs resources to id - && preciousWithoutSlot item) + && condCanProject + targetableEnemy (aidE, body) = do + tMelee <- targetableMelee aidE body + return $! targetableRangedOrSpecial body || tMelee + nearbyFoes <- filterM targetableEnemy allFoes + let unknownId = ouniqGroup "unknown space" + itemUsefulness itemFull = + fst <$> totalUsefulness cops b activeItems fact itemFull desirableBag bag = any (\(iid, k) -> - desirableItem iid (itemD EM.! iid) k) - $ EM.assocs bag + let itemFull = itemToF iid k + use = itemUsefulness itemFull + in desirableItem canEscape use itemFull) $ EM.assocs bag desirable (_, (_, Nothing)) = True desirable (_, (_, Just bag)) = desirableBag bag -- TODO: make more common when weak ranged foes preferred, etc. focused = bspeed b activeItems < speedNormal || condHpTooLow + couldMoveLastTurn = + let axtorSk = if (fst <$> gleader fact) == Just aid + then actorMaxSk + else actorMinSk + in EM.findWithDefault 0 AbMove axtorSk > 0 + isStuck = waitedLastTurn b && couldMoveLastTurn + slackTactic = ftactic (gplayer fact) `elem` [TBlock, TRoam, TPatrol] setPath :: Target -> m (Strategy (Target, Maybe PathEtc)) setPath tgt = do mpath <- createPath aid tgt - return $! returN "pickNewTarget" - $ maybe (tgt, Nothing) (\(t, p) -> (t, Just p)) mpath + let take5 (TEnemy{}, pgl) = + (tgt, Just pgl) -- for projecting, even by roaming actors + take5 (_, pgl@(path, (goal, _))) = + if slackTactic then + -- Best path only followed 5 moves; then straight on. + let path5 = take 5 path + vtgt | bpos b == goal = tgt + | otherwise = TVector $ towards (bpos b) goal + in (vtgt, Just (path5, (last path5, length path5 - 1))) + else (tgt, Just pgl) + return $! returN "setPath" $ maybe (tgt, Nothing) take5 mpath pickNewTarget :: m (Strategy (Target, Maybe PathEtc)) pickNewTarget = do + -- This is mostly lazy and used between 0 and 3 times below. + ctriggers <- closestTriggers Nothing aid -- TODO: for foes, items, etc. consider a few nearby, not just one cfoes <- closestFoes nearbyFoes aid case cfoes of @@ -157,65 +182,76 @@ else return [] case smpos of [] -> do - citems <- if EM.findWithDefault 0 AbMoveItem actorSk > 0 - then closestItems aid - else return [] - case filter desirable citems of - [] | ftactic (gplayer fact) == TRoam -> do - mtgtPrev <- getsClient $ getTarget aid - let vOld = bpos b `vectorToFrom` boldpos b - v = case (mtgtPrev, isUnit vOld) of - (Just (TVector tgtPrev), True) -> - if euclidDistSqVector tgtPrev vOld <= 2 - then tgtPrev - else vOld - (Just (TVector tgtPrev), False) -> tgtPrev - (_, True) -> vOld - (_, False) -> Vector 1 1 -- south-east - -- Items and smells considered every 5 moves. - -- Thanks to sentinels, @path@ is never null. - path = trajectoryToPathBounded - lxsize lysize (bpos b) (replicate 5 v) - return $! returN "tgt with no playerLeader" - ( TVector v - , Just (bpos b : path, (last path, length path)) ) - [] -> do - let lidExplored = ES.member (blid b) explored - upos <- if lidExplored - then return Nothing - else closestUnknown aid - case upos of - Nothing -> do - csuspect <- if lidExplored - then return [] - else closestSuspect aid - case csuspect of - [] -> do - ctriggers <- - if EM.findWithDefault 0 AbTrigger actorSk > 0 - then closestTriggers Nothing False aid - else return [] - case ctriggers of + let ctriggersEarly = + if EM.findWithDefault 0 AbTrigger actorMaxSk > 0 + && condEnoughGear + then ctriggers + else mzero + if nullFreq ctriggersEarly then do + citems <- + if EM.findWithDefault 0 AbMoveItem actorMaxSk > 0 + then closestItems aid + else return [] + case filter desirable citems of + [] -> do + let vToTgt v0 = do + let vFreq = toFreq "vFreq" + $ (20, v0) : map (1,) moves + v <- rndToAction $ frequency vFreq + -- Items and smells, etc. considered every 7 moves. + let tra = trajectoryToPathBounded + lxsize lysize (bpos b) (replicate 7 v) + path = nub $ bpos b : tra + return $! returN "tgt with no exploration" + ( TVector v + , if length path == 1 + then Nothing + else Just (path, (last path, length path - 1)) ) + vOld = bpos b `vectorToFrom` boldpos b + pNew = shiftBounded lxsize lysize (bpos b) vOld + if slackTactic && not isStuck + && isUnit vOld && bpos b /= pNew + && accessible cops lvl (bpos b) pNew + then vToTgt vOld + else do + upos <- if lidExplored + then return Nothing + else closestUnknown aid + case upos of + Nothing -> do + csuspect <- if lidExplored + then return [] + else closestSuspect aid + case csuspect of [] -> do - -- All stones turned, time to win or die. - afoes <- closestFoes allFoes aid - case afoes of - (_, (aid2, _)) : _ -> - setPath $ TEnemy aid2 False - [] -> do - getDistant <- - rndToAction $ oneOf - $ [fmap (: []) . furthestKnown] - ++ [ closestTriggers Nothing True - | EM.size dungeon > 1 ] - kpos <- getDistant aid - case kpos of - [] -> return reject - p : _ -> setPath $ TPoint (blid b) p + let ctriggersMiddle = + if EM.findWithDefault 0 AbTrigger + actorMaxSk > 0 + && not allExplored + then ctriggers + else mzero + if nullFreq ctriggersMiddle then do + -- All stones turned, time to win or die. + afoes <- closestFoes allFoes aid + case afoes of + (_, (aid2, _)) : _ -> + setPath $ TEnemy aid2 False + [] -> do + if nullFreq ctriggers then do + furthest <- furthestKnown aid + setPath $ TPoint (blid b) furthest + else do + p <- rndToAction $ frequency ctriggers + setPath $ TPoint (blid b) p + else do + p <- rndToAction $ frequency ctriggers + setPath $ TPoint (blid b) p p : _ -> setPath $ TPoint (blid b) p - p : _ -> setPath $ TPoint (blid b) p - Just p -> setPath $ TPoint (blid b) p - (_, (p, _)) : _ -> setPath $ TPoint (blid b) p + Just p -> setPath $ TPoint (blid b) p + (_, (p, _)) : _ -> setPath $ TPoint (blid b) p + else do + p <- rndToAction $ frequency ctriggers + setPath $ TPoint (blid b) p (_, (p, _)) : _ -> setPath $ TPoint (blid b) p tellOthersNothingHere pos = do let f (tgt, _) = case tgt of @@ -250,21 +286,21 @@ (oldTgt, Just ( bpos b : path , (p, fromMaybe (assert `failure` mpath) $ accessBfs bfs p) )) - TEnemyPos _ lid p permit -> + TEnemyPos _ lid p permit -- Chase last position even if foe hides or dies, -- to find his companions, loot, etc. - if lid /= blid b -- wrong level - || chessDist (bpos b) p >= nearby -- too far and not visible - || permit -- never follow a friend more than 1 step - then pickNewTarget - else if p == bpos b - then tellOthersNothingHere p - else return $! returN "TEnemyPos" (oldTgt, Just updatedPath) + | lid /= blid b -- wrong level + || chessDist (bpos b) p >= nearby -- too far and not visible + || permit -- never follow a friend more than 1 step + -> pickNewTarget + | p == bpos b -> tellOthersNothingHere p + | otherwise -> + return $! returN "TEnemyPos" (oldTgt, Just updatedPath) _ | not $ null nearbyFoes -> pickNewTarget -- prefer close foes to anything TPoint lid pos -> do - let allExplored = ES.size explored == EM.size dungeon bag <- getsState $ getCBag $ CFloor lid pos + let t = lvl `at` pos if lid /= blid b -- wrong level -- Below we check the target could not be picked again in -- pickNewTarget, and only in this case it is invalidated. @@ -272,16 +308,18 @@ -- shows up) and not changed all the time mid-route -- to equally interesting, but perhaps a bit closer targets, -- most probably already targeted by other actors. - || (EM.findWithDefault 0 AbMoveItem actorSk <= 0 -- closestItems - || not (desirableBag bag)) - && (not canSmell -- closestSmell - || pos == bpos b -- in case server resends deleted smell + || + (EM.findWithDefault 0 AbMoveItem actorMaxSk <= 0 + || not (desirableBag bag)) -- closestItems + && + (pos == bpos b + || (not canSmell -- closestSmell || let sml = EM.findWithDefault timeZero pos (lsmell lvl) in sml <= ltime lvl) - && let t = lvl `at` pos - in if ES.notMember lid explored + && if not lidExplored then t /= unknownId -- closestUnknown && not (Tile.isSuspect cotile t) -- closestSuspect + && not (condEnoughGear && Tile.isStair cotile t) else -- closestTriggers -- Try to kill that very last enemy for his loot before -- leaving the level or dungeon. @@ -293,21 +331,16 @@ -- We don't determine if the stairs are interesting -- (this changes with time), but allow the actor -- to reach them and then retarget, unless he can't - -- trigger them in the first place. - && (EM.findWithDefault 0 AbTrigger actorSk <= 0 - || pos == bpos b + -- trigger them at all. + && (EM.findWithDefault 0 AbTrigger actorMaxSk <= 0 || not (Tile.isStair cotile t)) -- The remaining case is furthestKnown. This is -- always an unimportant target, so we forget it -- if the actor is stuck (waits, though could move; -- or has zeroed individual moving skill, -- but then should change targets often anyway). - && let isStuck = - waitedLastTurn b - && canMoveFact fact (oldLeader == aid) - in pos == bpos b - || isStuck - || not allExplored + && (isStuck + || not allExplored)) then pickNewTarget else return $! returN "TPoint" (oldTgt, Just updatedPath) TVector{} | len > 1 -> @@ -324,6 +357,8 @@ mpos <- aidTgtToPos aid (blid b) (Just tgt) case mpos of Nothing -> return Nothing +-- TODO: for now, an extra turn at target is needed, e.g., to pick up items +-- Just p | p == bpos b -> return Nothing Just p -> do (bfs, mpath) <- getCacheBfsAndPath aid p return $! case mpath of diff --git a/Game/LambdaHack/Client/AI/Preferences.hs b/Game/LambdaHack/Client/AI/Preferences.hs --- a/Game/LambdaHack/Client/AI/Preferences.hs +++ b/Game/LambdaHack/Client/AI/Preferences.hs @@ -3,9 +3,8 @@ ( totalUsefulness, effectToBenefit ) where -import qualified Control.Monad.State as St +import Control.Applicative import qualified Data.EnumMap.Strict as EM -import Data.Maybe import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState @@ -28,73 +27,86 @@ let dungeonDweller = not $ fcanEscape $ gplayer fact in case eff of IK.NoEffect _ -> 0 - IK.Hurt d -> -(min 99 $ round (10 * Dice.meanDice d)) - IK.Burn p -> -15 * p -- usually splash damage, etc. - IK.Explode _ -> -10 + IK.Hurt d -> -(min 100 $ 10 * Dice.meanDice d) + IK.Burn d -> -(min 150 $ 15 * Dice.meanDice d) + -- often splash damage, etc. + IK.Explode _ -> 0 -- depends on explosion IK.RefillHP p -> let hpMax = sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems in if p > 0 - then 1 + 10 * min p (fromIntegral $ (xM hpMax - bhp b) `divUp` oneM) - else max (-99) (10 * p) + -- TODO: when picking up, always deem valuable; when drinking, only if + -- HP not maxxed. + then 10 * min p (max 0 $ fromIntegral + $ (xM hpMax - bhp b) `divUp` oneM) + else max (-99) (11 * p) IK.OverfillHP p -> let hpMax = sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems in if p > 0 - then 2 + 10 * min p (fromIntegral $ (xM hpMax - bhp b) `divUp` oneM) - else max (-99) (10 * p) + then 11 * min p (max 1 $ fromIntegral + $ (xM hpMax - bhp b) `divUp` oneM) + else max (-99) (11 * p) IK.RefillCalm p -> let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems in if p > 0 - then 1 + min p (fromIntegral $ (xM calmMax - bcalm b) `divUp` oneM) + then min p (max 0 $ fromIntegral + $ (xM calmMax - bcalm b) `divUp` oneM) else max (-20) p IK.OverfillCalm p -> let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems in if p > 0 - then 2 + min p (fromIntegral $ (xM calmMax - bcalm b) `divUp` oneM) + then min p (max 1 $ fromIntegral + $ (xM calmMax - bcalm b) `divUp` oneM) else max (-20) p IK.Dominate -> -200 IK.Impress -> -10 - IK.CallFriend d -> round $ 20 * Dice.meanDice d - IK.Summon{} | dungeonDweller -> 1 -- probably summons friends or crazies - IK.Summon{} -> 0 -- probably generates enemies - IK.Ascend{} -> 1 -- change levels sensibly, in teams - IK.Escape{} -> 10000 -- AI wants to win; spawners to guard - IK.Paralyze d -> round $ -20 * Dice.meanDice d - IK.InsertMove d -> round $ 50 * Dice.meanDice d + IK.CallFriend d -> 100 * Dice.meanDice d + IK.Summon _ d | dungeonDweller -> + -- Probably summons friends or crazies. + -- TODO: should be Negative, to use Calm of enemy, but also positive + -- to use with own Calm, if needed. + 50 * Dice.meanDice d + IK.Summon{} -> 0 -- probably generates enemies + IK.Ascend{} -> 1 -- low, to only change levels sensibly, in teams + -- TODO: use if low HP and enemies at hand + IK.Escape{} -> 10000 -- AI wants to win; spawners to guard + IK.Paralyze d -> -20 * Dice.meanDice d + IK.InsertMove d -> 50 * Dice.meanDice d IK.Teleport d -> - let p = round $ Dice.meanDice d - in if p <= 9 then 10 -- blink to shoot at foe - else if p <= 19 then 1 -- neither escape nor repositioning - else -5 * p -- get rid of the foe + let p = Dice.meanDice d + in if p <= 8 -- blink to shoot at foe + && dungeonDweller -- non-dwellers have to explore and escape ASAP + then 1 + else -p -- get rid of the foe IK.CreateItem COrgan grp _ -> -- TODO: use the timeout let (total, count) = organBenefit grp cops b in total `divUp` count -- average over all matching grp; rarities ignored - IK.CreateItem _ _ _ -> 30 + IK.CreateItem{} -> 30 -- TODO IK.DropItem COrgan grp True -> -- calculated for future use, general pickup let (total, _) = organBenefit grp cops b in - total -- sum over all matching grp; simplification: rarities ignored IK.DropItem _ _ False -> -15 IK.DropItem _ _ True -> -30 - IK.PolyItem _ -> 0 -- AI would loop - IK.Identify _ -> 1 -- not higher, or AI would loop + IK.PolyItem -> 0 -- AI can't estimate item desirability vs average + IK.Identify -> 0 -- AI doesn't know how to use IK.SendFlying _ -> -10 -- but useful on self sometimes, too IK.PushActor _ -> -10 -- but useful on self sometimes, too IK.PullActor _ -> -10 IK.DropBestWeapon -> -50 IK.ActivateInv ' ' -> -100 IK.ActivateInv _ -> -50 - IK.ApplyPerfume -> -10 + IK.ApplyPerfume -> 0 -- depends on the smell sense of friends and foes IK.OneOf _ -> 1 -- usually a mixed blessing, but slightly beneficial IK.OnSmash _ -> -10 - IK.Recharging e -> effectToBenefit cops b activeItems fact e - `divUp` 3 -- TODO: use Timeout + IK.Recharging e -> + -- Used, e.g., in @periodicBens@, which takes timeout into account, too. + effectToBenefit cops b activeItems fact e IK.Temporary _ -> 0 -- TODO: calculating this for "temporary conditions" takes forever organBenefit :: GroupName ItemKind -> Kind.COps -> Actor -> (Int, Int) organBenefit t cops@Kind.COps{coitem=Kind.Ops{ofoldrGroup}} b = - let travA x = St.evalState (IK.aspectTrav x (return . round . Dice.meanDice)) () - f p _ kind (sacc, pacc) = - let paspect asp = p * aspectToBenefit cops b (travA asp) + let f p _ kind (sacc, pacc) = + let paspect asp = p * aspectToBenefit cops b (Dice.meanDice <$> asp) in ( sacc + sum (map paspect $ IK.iaspects kind) , pacc + p ) in ofoldrGroup t f (0, 0) @@ -103,18 +115,19 @@ aspectToBenefit :: Kind.COps -> Actor -> IK.Aspect Int -> Int aspectToBenefit _cops _b asp = case asp of + IK.Unique{} -> 0 IK.Periodic{} -> 0 IK.Timeout{} -> 0 - IK.AddMaxHP p -> p * 10 - IK.AddMaxCalm p -> p `divUp` 2 - IK.AddSpeed p -> p * 10000 - IK.AddSkills m -> 5 * sum (EM.elems m) - IK.AddHurtMelee p -> p `divUp` 3 + IK.AddHurtMelee p -> p IK.AddHurtRanged p -> p `divUp` 5 -- TODO: should be summed with damage IK.AddArmorMelee p -> p `divUp` 5 IK.AddArmorRanged p -> p `divUp` 10 + IK.AddMaxHP p -> p + IK.AddMaxCalm p -> p `div` 5 + IK.AddSpeed p -> p * 10000 + IK.AddSkills m -> 5 * sum (EM.elems m) IK.AddSight p -> p * 10 - IK.AddSmell p -> p * 2 + IK.AddSmell p -> p * 10 IK.AddLight p -> p * 10 -- | Determine the total benefit from having an item in eqp or inv, @@ -134,26 +147,25 @@ Just timeout -> map (\eff -> eff * 10 `divUp` timeout) periodicEffBens selfBens = aspBens ++ periodicBens - eqpSum = if not (null selfBens) && minimum selfBens < -10 - && maximum selfBens > 10 - then 0 -- significant mixed blessings out of AI control - else sum selfBens + selfSum = sum selfBens + mixedBlessing = + not (null selfBens) + && (selfSum > 0 && minimum selfBens < -10 + || selfSum < 0 && maximum selfBens > 10) effSum = sum effBens - isWeapon = - isJust (strengthFromEqpSlot IK.EqpSlotWeapon itemFull) - totalSum = if goesIntoInv $ itemBase itemFull - then effSum - else if isWeapon && effSum < 0 - then - effSum + eqpSum - else eqpSum + isWeapon = isMeleeEqp itemFull + totalSum + | isWeapon && effSum < 0 = - effSum + selfSum + | goesIntoInv itemFull = effSum + | mixedBlessing = + 0 -- significant mixed blessings out of AI control + | otherwise = selfSum -- if the weapon heals the enemy, it + -- won't be used but can be equipped in (totalSum, effSum) in case itemDisco itemFull of Just ItemDisco{itemAE=Just ItemAspectEffect{jaspects, jeffects}} -> Just $ ben jeffects jaspects Just ItemDisco{itemKind=IK.ItemKind{iaspects, ieffects}} -> - let travA x = - St.evalState (IK.aspectTrav x (return . round . Dice.meanDice)) - () - jaspects = map travA iaspects + let jaspects = map (fmap Dice.meanDice) iaspects in Just $ ben ieffects jaspects _ -> Nothing 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,4 +1,4 @@ -{-# LANGUAGE TupleSections #-} +{-# 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. module Game.LambdaHack.Client.AI.Strategy @@ -8,8 +8,10 @@ import Control.Applicative import Control.Monad +import Data.Foldable (Foldable) import Data.Maybe import Data.Text (Text) +import Data.Traversable (Traversable) import Game.LambdaHack.Common.Frequency as Frequency import Game.LambdaHack.Common.Msg @@ -17,7 +19,7 @@ -- | A strategy is a choice of (non-empty) frequency tables -- of possible actions. newtype Strategy a = Strategy { runStrategy :: [Frequency a] } - deriving Show + deriving (Show, Foldable, Traversable) -- | Strategy is a monad. TODO: Can we write this as a monad transformer? instance Monad Strategy where @@ -98,6 +100,7 @@ returN :: Text -> a -> Strategy a returN name x = Strategy $ return $! uniformFreq name [x] +-- TODO: express with traverse? mapStrategyM :: Monad m => (a -> m (Maybe b)) -> Strategy a -> m (Strategy b) mapStrategyM f s = do let mapFreq freq = do 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,10 +1,10 @@ {-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -- | Breadth first search algorithms. module Game.LambdaHack.Client.Bfs - ( -- * Public API - BfsDistance, MoveLegal(..), apartBfs + ( BfsDistance, MoveLegal(..), apartBfs , fillBfs, findPathBfs, accessBfs #ifdef EXPOSE_INTERNAL + -- * Internal operations , minKnownBfs #endif ) where @@ -33,11 +33,16 @@ minKnownBfs = toEnum $ (1 + fromEnum (maxBound :: BfsDistance)) `div` 2 -- | The distance value that denote no legal path between points. +-- The next value is the minimal distance value assigned to paths +-- that don't enter any unknown tiles. apartBfs :: BfsDistance apartBfs = pred minKnownBfs --- TODO: costly; peephole optimize, optmize BFS, don't call so often +-- TODO: costly; use a ring buffer instead of the lists, don't call so often -- | Fill out the given BFS array. +-- Unsafe @PointArray@ operations are OK here, because the intermediate +-- values of the vector don't leak anywhere outside nor are kept unevaluated +-- and so they can't be overwritten by the unsafe side-effect. fillBfs :: (Point -> Point -> MoveLegal) -- ^ is a move from known tile legal -> (Point -> Point -> Bool) -- ^ is a move from unknown legal -> Point -- ^ starting position @@ -71,7 +76,7 @@ (mvsK, mvsU) = foldl' fKnown ([], []) moves upd = zip mvsK (repeat distance) ++ zip mvsU (repeat distCompl) - !a3 = a2 PointArray.// upd + !a3 = PointArray.unsafeUpdateA a2 upd in (mvsK ++ succK2, mvsU ++ succU2, a3) processUnknown (succU2, a2) pos = let fUnknown lU move = @@ -83,18 +88,16 @@ else lU mvsU = foldl' fUnknown [] moves upd = zip mvsU (repeat distCompl) - !a3 = a2 PointArray.// upd + !a3 = PointArray.unsafeUpdateA a2 upd in (mvsU ++ succU2, a3) (succU4, !a4) = foldl' processUnknown ([], a) predU (succK6, succU6, !a6) = foldl' processKnown ([], succU4, a4) predK - in if null succK6 && null succU6 - then a6 -- no more dungeon positions to check - else if distance == predMaxKnownBfs -- wasting one Known slot - then a6 -- too far - else bfs (succ distance) succK6 succU6 a6 - in PointArray.forceA -- no more modifications of this array - $ bfs (succ minKnownBfs) [origin] [] - (aInitial PointArray.// [(origin, minKnownBfs)]) + in if null succK6 && null succU6 -- no more dungeon positions to check + || distance == predMaxKnownBfs -- wasting one Known slot + then a6 -- too far + else bfs (succ distance) succK6 succU6 a6 + in bfs (succ minKnownBfs) [origin] [] + (PointArray.unsafeUpdateA aInitial [(origin, minKnownBfs)]) -- TODO: Use http://harablog.wordpress.com/2011/09/07/jump-point-search/ -- to determine a few really different paths and compare them, diff --git a/Game/LambdaHack/Client/BfsClient.hs b/Game/LambdaHack/Client/BfsClient.hs --- a/Game/LambdaHack/Client/BfsClient.hs +++ b/Game/LambdaHack/Client/BfsClient.hs @@ -1,11 +1,12 @@ {-# LANGUAGE CPP, TupleSections #-} -- | Breadth first search and realted algorithms using the client monad. module Game.LambdaHack.Client.BfsClient - ( getCacheBfsAndPath, getCacheBfs, accessCacheBfs + ( invalidateBfs, getCacheBfsAndPath, getCacheBfs, accessCacheBfs , unexploredDepth, closestUnknown, closestSuspect, closestSmell, furthestKnown , closestTriggers, closestItems, closestFoes ) where +import Control.Applicative import Control.Arrow ((&&&)) import Control.Exception.Assert.Sugar import Control.Monad @@ -22,7 +23,10 @@ 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.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.MonadStateRead @@ -32,8 +36,20 @@ 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.TileKind (TileKind) +invalidateBfs :: ActorId + -> EM.EnumMap ActorId + ( Bool, PointArray.Array BfsDistance + , Point, Int, Maybe [Point]) + -> EM.EnumMap ActorId + ( Bool, PointArray.Array BfsDistance + , Point, Int, Maybe [Point]) +invalidateBfs = + EM.adjust + (\(_, bfs, target, seps, mpath) -> (False, bfs, target, seps, mpath)) + -- | Get cached BFS data and path or, if not stored, generate, -- store and return. Due to laziness, they are not calculated until needed. getCacheBfsAndPath :: forall m. MonadClient m @@ -49,19 +65,29 @@ pathAndStore bfs = do let mpath = findPathBfs isEnterable passUnknown origin target seps bfs modifyClient $ \cli -> - cli {sbfsD = EM.insert aid (bfs, target, seps, mpath) (sbfsD cli)} + cli {sbfsD = EM.insert aid (True, bfs, target, seps, mpath) + (sbfsD cli)} return (bfs, mpath) mbfs <- getsClient $ EM.lookup aid . sbfsD case mbfs of - Just (bfs, targetOld, sepsOld, mpath) + Just (True, bfs, targetOld, sepsOld, mpath) -- TODO: hack: in screensavers this is not always ensured, so check here: | bfs PointArray.! bpos b == succ apartBfs -> if targetOld == target && sepsOld == seps then return (bfs, mpath) else pathAndStore bfs _ -> do + -- Reduce the number of pointers to @bfsInvalid@, to help @safeSetA@. + modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli} Level{lxsize, lysize} <- getLevel $ blid b - let vInitial = PointArray.replicateA lxsize lysize apartBfs + let vInitial = case mbfs of + Just (_, bfsInvalid, _, _, _) -> -- TODO: we should verify size + -- We need to use the safe set, because previous values + -- of the BFS array for the actor can be stuck unevaluated + -- in thunks and we are not allowed to overwrite them. + PointArray.safeSetA apartBfs bfsInvalid + _ -> + PointArray.replicateA lxsize lysize apartBfs bfs = fillBfs isEnterable passUnknown origin vInitial pathAndStore bfs @@ -70,8 +96,8 @@ getCacheBfs aid = do mbfs <- getsClient $ EM.lookup aid . sbfsD case mbfs of - Just (bfs, _, _, _) -> return bfs - Nothing -> fmap fst $ getCacheBfsAndPath aid (Point 0 0) + Just (True, bfs, _, _, _) -> return bfs + _ -> fst <$> getCacheBfsAndPath aid (Point 0 0) condBFS :: MonadClient m => ActorId @@ -86,15 +112,22 @@ -- to reset BFS after leader changes, but it would still lead to -- wasted movement if, e.g., non-leaders move but only leaders open doors -- and leader change is very rare. - actorSk <- maxActorSkillsClient aid + activeItems <- activeItemsClient aid + let actorMaxSk = sumSkills activeItems lvl <- getLevel $ blid b + smarkSuspect <- getsClient smarkSuspect + fact <- getsState $ (EM.! bfid b) . sfactionD + let underAI = isAIFact fact + enterSuspect = smarkSuspect || underAI + isPassable | enterSuspect = Tile.isPassable + | otherwise = Tile.isPassableNoSuspect -- We treat doors as an open tile and don't add an extra step for opening -- the doors, because other actors open and use them, too, -- so it's amortized. We treat unknown tiles specially. let unknownId = ouniqGroup "unknown space" chAccess = checkAccess cops lvl - canOpenDoors = EM.findWithDefault 0 Ability.AbAlter actorSk > 0 - chDoorAccess = if canOpenDoors then [checkDoorAccess cops lvl] else [] + canOpenDoors = EM.findWithDefault 0 Ability.AbAlter actorMaxSk > 0 + chDoorAccess = [checkDoorAccess cops lvl | canOpenDoors] conditions = catMaybes $ chAccess : chDoorAccess -- Legality of move from a known tile, assuming doors freely openable. isEnterable :: Point -> Point -> MoveLegal @@ -107,7 +140,7 @@ then if not (Tile.isSuspect cotile st) && allOK then MoveToUnknown else MoveBlocked - else if Tile.isPassable cotile tt + else if isPassable cotile tt && not (Tile.isChangeable cotile st) -- takes time to change && allOK then MoveToOpen @@ -144,20 +177,25 @@ -- | Closest reachable unknown tile position, if any. closestUnknown :: MonadClient m => ActorId -> m (Maybe Point) closestUnknown aid = do + body <- getsState $ getActorBody aid + lvl@Level{lxsize, lysize} <- getLevel $ blid body bfs <- getCacheBfs aid - getMinIndex <- rndToAction $ oneOf [ PointArray.minIndexA - , PointArray.minLastIndexA ] - let closestPos = getMinIndex bfs - dist = bfs PointArray.! closestPos + let closestPoss = PointArray.minIndexesA bfs + dist = bfs PointArray.! head closestPoss if dist >= apartBfs then do - body <- getsState $ getActorBody aid - lvl <- getLevel $ blid body when (lclear lvl == lseen lvl) $ do -- explored fully, mark it once for all - assert (lclear lvl >= lseen lvl) skip + let !_A = assert (lclear lvl >= lseen lvl) () modifyClient $ \cli -> cli {sexplored = ES.insert (blid body) (sexplored cli)} return Nothing - else return $ Just closestPos + else do + let unknownAround p = + let vic = vicinity lxsize lysize p + posUnknown pos = bfs PointArray.! pos < apartBfs + vicUnknown = filter posUnknown vic + in length vicUnknown + cmp = comparing unknownAround + return $ Just $ maximumBy cmp closestPoss -- TODO: this is costly, because target has to be changed every -- turn when walking along trail. But inverting the sort and going @@ -209,53 +247,71 @@ -- TODO: We assume linear dungeon in @unexploredD@, -- because otherwise we'd need to calculate shortest paths in a graph, etc. -- | Closest (wrt paths) triggerable open tiles. --- The second argument can ever be true only if there's --- no escape from the dungeon. -closestTriggers :: MonadClient m => Maybe Bool -> Bool -> ActorId -> m [Point] -closestTriggers onlyDir exploredToo aid = do +-- 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. +closestTriggers :: MonadClient m => Maybe Bool -> ActorId -> m (Frequency Point) +closestTriggers onlyDir aid = do Kind.COps{cotile} <- getsState scops body <- getsState $ getActorBody aid + explored <- getsClient sexplored let lid = blid body lvl <- getLevel lid dungeon <- getsState sdungeon - explored <- getsClient sexplored + let escape = any (not . null . lescape) $ EM.elems dungeon unexploredD <- unexploredDepth let allExplored = ES.size explored == EM.size dungeon + -- If lid not explored, aid equips a weapon and so can leave level. + lidExplored = ES.member (blid body) explored f :: [(Int, Point)] -> Point -> Kind.Id TileKind -> [(Int, Point)] f acc p t = if Tile.isWalkable cotile t && not (null $ Tile.causeEffects cotile t) - then if exploredToo - then (1, p) : acc -- direction irrelevant - else case Tile.ascendTo cotile t of - [] -> - -- Escape (or guard) after exploring, for high score, etc. - if allExplored then (1, p) : acc else acc - l -> - let g k = k > 0 - && onlyDir /= Just False - && unexploredD 1 lid - || - k < 0 - && onlyDir /= Just True - && unexploredD (-1) lid + then case Tile.ascendTo cotile t of + [] -> + -- Escape (or guard) only after exploring, for high score, etc. + if isNothing onlyDir && allExplored + then (9999999, p) : acc -- all from that level congregate here + else acc + l -> + if not escape && allExplored + -- Direction irrelevant; wander randomly. + then map (,p) l ++ acc + else let g k = + let easier = signum k /= signum (fromEnum lid) + unexpForth = unexploredD (signum k) lid + unexpBack = unexploredD (- signum k) lid + aiCond = if unexpForth + then easier + || not unexpBack && lidExplored + else not unexpBack && lidExplored + && (null $ lescape lvl) + in maybe aiCond (\d -> d == (k > 0)) onlyDir in map (,p) (filter g l) ++ acc else acc - let triggersAll = PointArray.ifoldlA f [] $ ltile lvl + triggersAll = PointArray.ifoldlA f [] $ ltile lvl -- Don't target stairs under the actor. Most of the time they -- are blocked and stay so, so we seek other stairs, if any. - -- If no other stairs in this direction, let's wait here. - triggers | length triggersAll > 1 = - filter ((/= bpos body) . snd) triggersAll - | otherwise = triggersAll - case triggers of - [] -> return [] - _ -> do - bfs <- getCacheBfs aid + -- If no other stairs in this direction, let's wait here, + -- unless the actor has just returned via the very stairs. + triggers = filter ((/= bpos body) . snd) triggersAll + bfs <- getCacheBfs aid + return $ case triggers of -- keep lazy + [] -> mzero + _ | isNothing onlyDir && not escape && allExplored -> + -- Distance also irrelevant, to ensure random wandering. + toFreq "closestTriggers when allExplored" triggers + _ -> -- Prefer stairs to easier levels. - let mix (k, p) dist = ((abs (fromEnum lid + k), dist), p) - ds = mapMaybe (\(k, p) -> fmap (mix (k, p)) (accessBfs bfs p)) - triggers - return $! map snd $ sortBy (comparing fst) ds + -- If exactly one escape, these stairs will all be in one direction. + let mix (k, p) dist = + let easier = signum k /= signum (fromEnum lid) + depthDelta = if easier then 2 else 1 + distDelta = fromEnum (maxBound :: BfsDistance) + - fromEnum apartBfs + - dist + in (depthDelta * distDelta * distDelta, p) + ds = mapMaybe (\(k, p) -> mix (k, p) <$> accessBfs bfs p) triggers + in toFreq "closestTriggers" ds unexploredDepth :: MonadClient m => m (Int -> LevelId -> Bool) unexploredDepth = do @@ -263,14 +319,15 @@ explored <- getsClient sexplored let allExplored = ES.size explored == EM.size dungeon unexploredD p = - let unex lid = allExplored && lescape (dungeon EM.! lid) + let unex lid = allExplored + && (not $ null $ lescape $ dungeon EM.! lid) || ES.notMember lid explored || unexploredD p lid in any unex . ascendInBranch dungeon p return unexploredD -- | Closest (wrt paths) items and changeable tiles (e.g., item caches). -closestItems :: MonadClient m => ActorId -> m ([(Int, (Point, Maybe ItemBag))]) +closestItems :: MonadClient m => ActorId -> m [(Int, (Point, Maybe ItemBag))] closestItems aid = do Kind.COps{cotile} <- getsState scops body <- getsState $ getActorBody aid @@ -291,7 +348,7 @@ -- | Closest (wrt paths) enemy actors. closestFoes :: MonadClient m => [(ActorId, Actor)] -> ActorId -> m [(Int, (ActorId, Actor))] -closestFoes foes aid = do +closestFoes foes aid = case foes of [] -> return [] _ -> do diff --git a/Game/LambdaHack/Client/CommonClient.hs b/Game/LambdaHack/Client/CommonClient.hs --- a/Game/LambdaHack/Client/CommonClient.hs +++ b/Game/LambdaHack/Client/CommonClient.hs @@ -3,16 +3,15 @@ module Game.LambdaHack.Client.CommonClient ( getPerFid, aidTgtToPos, aidTgtAims, makeLine , partAidLeader, partActorLeader, partPronounLeader - , actorSkillsClient, maxActorSkillsClient - , updateItemSlot, fullAssocsClient, activeItemsClient - , itemToFullClient, pickWeaponClient, sumOrganEqpClient, getModeClient + , actorSkillsClient, updateItemSlot, fullAssocsClient, activeItemsClient + , itemToFullClient, pickWeaponClient, sumOrganEqpClient ) where +import Control.Applicative import Control.Exception.Assert.Sugar +import Control.Monad import qualified Data.EnumMap.Strict as EM -import qualified Data.IntMap.Strict as IM import Data.Maybe -import Data.Text (Text) import Data.Tuple import qualified NLP.Miniutter.English as MU @@ -22,7 +21,6 @@ import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState -import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest @@ -30,21 +28,22 @@ import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Msg 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.Vector -import Game.LambdaHack.Content.ModeKind +import qualified Game.LambdaHack.Content.ItemKind as IK -- | Get the current perception of a client. getPerFid :: MonadClient m => LevelId -> m Perception getPerFid lid = do fper <- getsClient sfper - return $! fromMaybe (assert `failure` "no perception at given level" - `twith` (lid, fper)) - $ EM.lookup lid fper + let assFail = assert `failure` "no perception at given level" + `twith` (lid, fper) + return $! EM.findWithDefault assFail lid fper -- | The part of speech describing the actor or "you" if a leader -- of the client's faction. The actor may be not present in the dungeon. @@ -107,23 +106,37 @@ -- because the target actor can be obscured by a glass wall -- or be out of sight range, but in weapon range. aidTgtAims :: MonadClient m - => ActorId -> LevelId -> Maybe Target -> m (Either Text Int) + => ActorId -> LevelId -> Maybe Target -> m (Either Msg Int) aidTgtAims aid lidV tgt = do - oldEps <- getsClient seps + let findNewEps onlyFirst pos = do + oldEps <- getsClient seps + b <- getsState $ getActorBody aid + 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" case tgt of Just (TEnemy a _) -> do body <- getsState $ getActorBody a let pos = bpos body + if blid body == lidV + then findNewEps False pos + else return $ Left "selected opponent not on this level" + Just TEnemyPos{} -> return $ Left "selected opponent not visible" + Just (TPoint lid pos) -> + if lid == lidV + then findNewEps True pos + else return $ Left "selected position not on this level" + Just (TVector v) -> do b <- getsState $ getActorBody aid - if blid b == lidV then do - mnewEps <- makeLine b pos oldEps - case mnewEps of - Just newEps -> return $ Right newEps - Nothing -> return $ Left "aiming line to the opponent blocked" - else return $ Left "target opponent not on this level" - Just TEnemyPos{} -> return $ Left "target opponent not visible" - Just TPoint{} -> return $ Right oldEps - Just TVector{} -> return $ Right oldEps + 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 Nothing -> do scursor <- getsClient scursor aidTgtAims aid lidV $ Just scursor @@ -132,8 +145,8 @@ -- 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 => Actor -> Point -> Int -> m (Maybe Int) -makeLine body fpos epsOld = do +makeLine :: MonadClient m => Bool -> Actor -> Point -> Int -> m (Maybe Int) +makeLine onlyFirst body fpos epsOld = do cops@Kind.COps{cotile=Kind.Ops{ouniqGroup}} <- getsState scops lvl@Level{lxsize, lysize} <- getLevel (blid body) bs <- getsState $ filter (not . bproj) @@ -147,53 +160,64 @@ noActor p = all ((/= p) . bpos) bs || p == fpos accessU = all noActor blDist && all (uncurry $ accessibleUnknown cops lvl) blZip + accessFirst | not onlyFirst = False + | otherwise = + all noActor (take 1 blDist) + && all (uncurry $ accessibleUnknown cops lvl) (take 1 blZip) nUnknown = length $ filter ((== unknownId) . (lvl `at`)) blDist - in if accessU then - nUnknown else minBound + in if accessU then - nUnknown + else if accessFirst then -10000 + else minBound Nothing -> assert `failure` (body, fpos, epsOld) - tryLines curEps (acc, _) | curEps >= epsOld + dist = acc + tryLines curEps (acc, _) | curEps == epsOld + dist = acc tryLines curEps (acc, bestScore) = let curScore = calcScore curEps newAcc = if curScore > bestScore then (Just curEps, curScore) else (acc, bestScore) in tryLines (curEps + 1) newAcc - return $! if dist <= 1 - then Nothing -- ProjectBlockActor, ProjectAimOnself - else tryLines epsOld (Nothing, minBound) + return $! if dist <= 0 then Nothing -- ProjectAimOnself + else if calcScore epsOld > minBound then Just epsOld -- keep old + else tryLines (epsOld + 1) (Nothing, minBound) -- generate best actorSkillsClient :: MonadClient m => ActorId -> m Ability.Skills actorSkillsClient aid = do activeItems <- activeItemsClient aid + body <- getsState $ getActorBody aid + fact <- getsState $ (EM.! bfid body) . sfactionD + side <- getsClient sside -- Newest Leader in _sleader, not yet in sfactionD. - mleader <- getsClient _sleader + mleader1 <- if side == bfid body then getsClient _sleader else return Nothing + let mleader2 = fst <$> gleader fact + mleader = mleader1 `mplus` mleader2 getsState $ actorSkills mleader aid activeItems -maxActorSkillsClient :: MonadClient m - => ActorId -> m Ability.Skills -maxActorSkillsClient aid = do - activeItems <- activeItemsClient aid - getsState $ maxActorSkills aid activeItems - -updateItemSlot :: MonadClient m => Maybe ActorId -> ItemId -> m () -updateItemSlot maid iid = do - slots@(letterSlots, numberSlots) <- getsClient sslots - case ( lookup iid $ map swap $ EM.assocs letterSlots - , lookup iid $ map swap $ IM.assocs numberSlots ) of - (Nothing, Nothing) -> do +updateItemSlot :: MonadClient m + => CStore -> Maybe ActorId -> ItemId -> m SlotChar +updateItemSlot store maid iid = do + slots@(itemSlots, organSlots) <- getsClient sslots + let onlyOrgans = store == COrgan + lSlots = if onlyOrgans then organSlots else itemSlots + incrementPrefix m l iid2 = EM.insert l iid2 $ + case EM.lookup l m of + Nothing -> m + Just iidOld -> + let lNew = SlotChar (slotPrefix l + 1) (slotChar l) + in incrementPrefix m lNew iidOld + case lookup iid $ map swap $ EM.assocs lSlots of + Nothing -> do side <- getsClient sside item <- getsState $ getItemBody iid lastSlot <- getsClient slastSlot mb <- maybe (return Nothing) (fmap Just . getsState . getActorBody) maid - el <- getsState $ assignSlot item side mb slots lastSlot - case el of - Left l -> - modifyClient $ \cli -> - cli { sslots = (EM.insert l iid letterSlots, numberSlots) - , slastSlot = max l (slastSlot cli) } - Right l -> - modifyClient $ \cli -> - cli { sslots = (letterSlots, IM.insert l iid numberSlots) } - _ -> return () -- slot already assigned; a letter or a number + l <- getsState $ assignSlot store item side mb slots lastSlot + let newSlots | onlyOrgans = ( itemSlots + , incrementPrefix organSlots l iid ) + | otherwise = ( incrementPrefix itemSlots l iid + , organSlots ) + modifyClient $ \cli -> cli {sslots = newSlots} + return l + Just l -> return l -- slot already assigned; a letter or a number fullAssocsClient :: MonadClient m => ActorId -> [CStore] -> m [(ItemId, ItemFull)] @@ -221,37 +245,33 @@ -- Client has to choose the weapon based on its partial knowledge, -- because if server chose it, it would leak item discovery information. pickWeaponClient :: MonadClient m - => ActorId -> ActorId -> m [RequestTimed Ability.AbMelee] + => ActorId -> ActorId + -> m (Maybe (RequestTimed 'Ability.AbMelee)) pickWeaponClient source target = do eqpAssocs <- fullAssocsClient source [CEqp] bodyAssocs <- fullAssocsClient source [COrgan] actorSk <- actorSkillsClient source sb <- getsState $ getActorBody source + localTime <- getsState $ getLocalTime (blid sb) let allAssocs = eqpAssocs ++ bodyAssocs calm10 = calmEnough10 sb $ map snd allAssocs forced = assert (not $ bproj sb) False - legalPrecious = either (const False) id . permittedPrecious calm10 forced - strongest = strongestSlotNoFilter IK.EqpSlotWeapon allAssocs - strongestLegal = filter (legalPrecious . snd . snd) strongest - case strongestLegal of - _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> return [] - [] -> return [] + permitted = permittedPrecious calm10 forced + preferredPrecious = either (const False) id . permitted + strongest = strongestMelee True localTime allAssocs + strongestPreferred = filter (preferredPrecious . snd . snd) strongest + case strongestPreferred of + _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> return Nothing + [] -> return Nothing iis@((maxS, _) : _) -> do let maxIis = map snd $ takeWhile ((== maxS) . fst) iis - -- TODO: pick the item according to the frequency of its kind. (iid, _) <- rndToAction $ oneOf maxIis -- Prefer COrgan, to hint to the player to trash the equivalent CEqp item. let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp - return $! [ReqMelee target iid cstore] + return $ Just $ ReqMelee target iid cstore sumOrganEqpClient :: MonadClient m => IK.EqpSlot -> ActorId -> m Int sumOrganEqpClient eqpSlot aid = do activeItems <- activeItemsClient aid return $! sumSlotNoFilter eqpSlot activeItems - -getModeClient :: MonadClient m => m ModeKind -getModeClient = do - Kind.COps{comode=Kind.Ops{okind, ouniqGroup}} <- getsState scops - t <- getsClient sgameMode - return $! okind $ ouniqGroup t diff --git a/Game/LambdaHack/Client/HandleAtomicClient.hs b/Game/LambdaHack/Client/HandleAtomicClient.hs --- a/Game/LambdaHack/Client/HandleAtomicClient.hs +++ b/Game/LambdaHack/Client/HandleAtomicClient.hs @@ -10,7 +10,6 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Maybe -import qualified Data.Text as T import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Atomic @@ -28,11 +27,9 @@ import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception -import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Content.ItemKind (ItemKind) -import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.TileKind as TK -- * RespUpdAtomicAI @@ -42,15 +39,6 @@ -- of commands kept for each command received. cmdAtomicFilterCli :: MonadClient m => UpdAtomic -> m [UpdAtomic] cmdAtomicFilterCli cmd = case cmd of - UpdMoveActor aid _ toP -> do - cmdSml <- deleteSmell aid toP - return $ [cmd] ++ cmdSml - UpdDisplaceActor source target -> do - bs <- getsState $ getActorBody source - bt <- getsState $ getActorBody target - cmdSource <- deleteSmell source (bpos bt) - cmdTarget <- deleteSmell target (bpos bs) - return $ [cmd] ++ cmdSource ++ cmdTarget UpdAlterTile lid p fromTile toTile -> do Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops lvl <- getLevel lid @@ -66,7 +54,7 @@ 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 $ T.pack $ show p + , "at position", MU.Text $ tshow p , "suddenly" -- adverb , MU.SubjectVerbSg subject verb , MU.AW $ MU.Text $ TK.tname $ okind toTile ] @@ -91,9 +79,7 @@ UpdLearnSecrets aid fromS _toS -> do b <- getsState $ getActorBody aid lvl <- getLevel $ blid b - return $! if lsecret lvl == fromS - then [cmd] -- secrets revealed now - else [] -- secrets already revealed previously + return $! [cmd | lsecret lvl == fromS] -- secrets not revealed previously UpdSpotTile lid ts -> do Kind.COps{cotile} <- getsState scops lvl <- getLevel lid @@ -107,17 +93,7 @@ || t /= Tile.hideAs cotile tClient) newTs = filter notKnown ts return $! if null newTs then [] else [UpdSpotTile lid newTs] - UpdAlterSmell lid p fromSm _toSm -> do - lvl <- getLevel lid - let msml = EM.lookup p $ lsmell lvl - return $ if msml /= fromSm then - -- Revert to the server smell before server command executes. - -- This is needed due to our hacky removal of traversed smells - -- in @deleteSmell@. - [UpdAlterSmell lid p msml fromSm, cmd] - else - [cmd] - UpdDiscover lid p iid _ seed -> do + UpdDiscover c iid _ seed -> do itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> return [] @@ -128,9 +104,9 @@ discoEffect <- getsClient sdiscoEffect if iid `EM.member` discoEffect then return [] - else return [UpdDiscoverSeed lid p iid seed] + else return [UpdDiscoverSeed c iid seed] else return [cmd] - UpdCover lid p iid ik _ -> do + UpdCover c iid ik _ -> do itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> return [] @@ -142,8 +118,8 @@ discoEffect <- getsClient sdiscoEffect if iid `EM.notMember` discoEffect then return [cmd] - else return [UpdCoverKind lid p iid ik] - UpdDiscoverKind _ _ iid _ -> do + else return [UpdCoverKind c iid ik] + UpdDiscoverKind _ iid _ -> do itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> return [] @@ -152,7 +128,7 @@ if jkindIx item `EM.notMember` discoKind then return [] else return [cmd] - UpdCoverKind _ _ iid _ -> do + UpdCoverKind _ iid _ -> do itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> return [] @@ -161,7 +137,7 @@ if jkindIx item `EM.notMember` discoKind then return [] else return [cmd] - UpdDiscoverSeed _ _ iid _ -> do + UpdDiscoverSeed _ iid _ -> do itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> return [] @@ -174,7 +150,7 @@ if iid `EM.member` discoEffect then return [] else return [cmd] - UpdCoverSeed _ _ iid _ -> do + UpdCoverSeed _ iid _ -> do itemD <- getsState sitemD case EM.lookup iid itemD of Nothing -> return [] @@ -234,29 +210,18 @@ -- TODO: these assertions are probably expensive psActor <- mapM posUpdAtomic outActor -- Verify that we forget only previously seen actors. - assert (allB seenOld psActor) skip + let !_A = assert (allB seenOld psActor) () -- Verify that we forget only currently invisible actors. - assert (allB (not . seenNew) psActor) skip + let !_A = assert (allB (not . seenNew) psActor) () let inTileSmell = inFloor ++ inEmbed ++ inSmell psItemSmell <- mapM posUpdAtomic inTileSmell -- Verify that we forget only previously invisible items and smell. - assert (allB (not . seenOld) psItemSmell) skip + let !_A = assert (allB (not . seenOld) psItemSmell) () -- Verify that we forget only currently seen items and smell. - assert (allB seenNew psItemSmell) skip + let !_A = assert (allB seenNew psItemSmell) () return $! cmd : outActor ++ inTileSmell _ -> return [cmd] -deleteSmell :: MonadClient m => ActorId -> Point -> m [UpdAtomic] -deleteSmell aid pos = do - b <- getsState $ getActorBody aid - smellRadius <- sumOrganEqpClient IK.EqpSlotAddSmell aid - if smellRadius <= 0 then return [] - else do - lvl <- getLevel $ blid b - let msml = EM.lookup pos $ lsmell lvl - return $ - maybe [] (\sml -> [UpdAlterSmell (blid b) pos (Just sml) Nothing]) msml - -- | Effect of atomic actions on client state is calculated -- in the global state before the command is executed. cmdAtomicSemCli :: MonadClient m => UpdAtomic -> m () @@ -269,9 +234,10 @@ side <- getsClient sside when (side == fid) $ do mleader <- getsClient _sleader - assert (mleader == fmap fst source -- somebody changed the leader for us - || mleader == fmap fst target -- we changed the leader ourselves - `blame` "unexpected leader" `twith` (cmd, mleader)) skip + let !_A = assert (mleader == fmap fst source -- somebody changed the leader for us + || mleader == fmap fst target -- we changed the leader ourselves + `blame` "unexpected leader" + `twith` (cmd, mleader)) () modifyClient $ \cli -> cli {_sleader = fmap fst target} case target of Nothing -> return () @@ -289,18 +255,18 @@ cli { stargetD = case (mtgt, mleader) of (Just tgt, Just leader) -> EM.singleton leader tgt _ -> EM.empty } - UpdDiscover lid p iid ik seed -> do - discoverKind lid p iid ik - discoverSeed lid p iid seed - UpdCover lid p iid ik seed -> do - coverSeed lid p iid seed - coverKind lid p iid ik - UpdDiscoverKind lid p iid ik -> discoverKind lid p iid ik - UpdCoverKind lid p iid ik -> coverKind lid p iid ik - UpdDiscoverSeed lid p iid seed -> discoverSeed lid p iid seed - UpdCoverSeed lid p iid seed -> coverSeed lid p iid seed + UpdDiscover c iid ik seed -> do + discoverKind c iid 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 + 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 _ sdebugCli sgameMode -> do + UpdRestart side sdiscoKind sfper _ sdebugCli -> do shistory <- getsClient shistory sreport <- getsClient sreport isAI <- getsClient sisAI @@ -309,7 +275,6 @@ , sfper -- , sundo = [UpdAtomic cmd] , scurDifficulty = sdifficultyCli sdebugCli - , sgameMode , sdebugCli } UpdResume _fid sfper -> modifyClient $ \cli -> cli {sfper} UpdKillExit _fid -> killExit @@ -368,26 +333,26 @@ modifyClient $ \cli -> cli {sfper = f (sfper cli)} discoverKind :: MonadClient m - => LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m () -discoverKind lid p iid ik = do + => Container -> ItemId -> Kind.Id ItemKind -> m () +discoverKind c iid ik = do item <- getsState $ getItemBody iid let f Nothing = Just ik f Just{} = assert `failure` "already discovered" - `twith` (lid, p, iid, ik) + `twith` (c, iid, ik) modifyClient $ \cli -> cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)} coverKind :: MonadClient m - => LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m () -coverKind lid p iid ik = do + => Container -> ItemId -> Kind.Id ItemKind -> m () +coverKind c iid ik = do item <- getsState $ getItemBody iid - let f Nothing = assert `failure` "already covered" `twith` (lid, p, iid, ik) + let f Nothing = assert `failure` "already covered" `twith` (c, iid, ik) f (Just ik2) = assert (ik == ik2 `blame` "unexpected covered item kind" `twith` (ik, ik2)) Nothing modifyClient $ \cli -> cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)} discoverSeed :: MonadClient m - => LevelId -> Point -> ItemId -> ItemSeed -> m () -discoverSeed lid p iid seed = do + => Container -> ItemId -> ItemSeed -> m () +discoverSeed c iid seed = do Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops discoKind <- getsClient sdiscoKind item <- getsState $ getItemBody iid @@ -395,18 +360,18 @@ totalDepth <- getsState stotalDepth case EM.lookup (jkindIx item) discoKind of Nothing -> assert `failure` "kind not known" - `twith` (lid, p, iid, seed) + `twith` (c, iid, seed) Just ik -> do let kind = okind ik f Nothing = Just $ seedToAspectsEffects seed kind ldepth totalDepth f Just{} = assert `failure` "already discovered" - `twith` (lid, p, iid, seed) + `twith` (c, iid, seed) modifyClient $ \cli -> cli {sdiscoEffect = EM.alter f iid (sdiscoEffect cli)} coverSeed :: MonadClient m - => LevelId -> Point -> ItemId -> ItemSeed -> m () -coverSeed lid p iid ik = do - let f Nothing = assert `failure` "already covered" `twith` (lid, p, iid, ik) + => Container -> ItemId -> ItemSeed -> m () +coverSeed c iid ik = do + let f Nothing = assert `failure` "already covered" `twith` (c, iid, ik) f Just{} = Nothing -- checking that old and new agree is too much work modifyClient $ \cli -> cli {sdiscoEffect = EM.alter f iid (sdiscoEffect cli)} diff --git a/Game/LambdaHack/Client/HandleResponseClient.hs b/Game/LambdaHack/Client/HandleResponseClient.hs --- a/Game/LambdaHack/Client/HandleResponseClient.hs +++ b/Game/LambdaHack/Client/HandleResponseClient.hs @@ -4,8 +4,6 @@ ( handleResponseAI, handleResponseUI ) where -import Control.Exception.Assert.Sugar - import Game.LambdaHack.Atomic import Game.LambdaHack.Client.AI import Game.LambdaHack.Client.HandleAtomicClient @@ -19,8 +17,8 @@ storeUndo :: MonadClient m => CmdAtomic -> m () storeUndo _atomic = - maybe skip (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli}) - $ Nothing -- TODO: undoCmdAtomic atomic + maybe (return ()) (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli}) + Nothing -- TODO: undoCmdAtomic atomic handleResponseAI :: (MonadAtomic m, MonadClientWriteRequest RequestAI m) => ResponseAI -> m () diff --git a/Game/LambdaHack/Client/ItemSlot.hs b/Game/LambdaHack/Client/ItemSlot.hs --- a/Game/LambdaHack/Client/ItemSlot.hs +++ b/Game/LambdaHack/Client/ItemSlot.hs @@ -6,14 +6,15 @@ , allSlots, slotLabel, slotRange, assignSlot ) where +import Control.Exception.Assert.Sugar import Data.Binary +import Data.Bits (shiftL, shiftR) import Data.Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import qualified Data.IntMap.Strict as IM import Data.List -import Data.Maybe import Data.Monoid +import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU @@ -25,17 +26,27 @@ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.State -newtype SlotChar = SlotChar {slotChar :: Char} - deriving (Show, Eq, Binary) +data SlotChar = SlotChar {slotPrefix :: Int, slotChar :: Char} + deriving (Show, Eq) instance Ord SlotChar where - compare x y = compare (fromEnum x) (fromEnum y) + compare = comparing fromEnum +instance Binary SlotChar where + put = put . fromEnum + get = fmap toEnum get + instance Enum SlotChar where - fromEnum (SlotChar x) = fromEnum x + if isUpper x then 1000 else 0 - toEnum e = SlotChar $ toEnum $ e - (if e > 1000 then 1000 else 0) + fromEnum (SlotChar n c) = + ord c + (if isUpper c then 100 else 0) + shiftL n 8 + toEnum e = + let n = shiftR e 8 + c0 = e - shiftL n 8 + c100 = c0 - if c0 > 150 then 100 else 0 + in SlotChar n (chr c100) -type ItemSlots = (EM.EnumMap SlotChar ItemId, IM.IntMap ItemId) +type ItemSlots = ( EM.EnumMap SlotChar ItemId + , EM.EnumMap SlotChar ItemId ) slotRange :: [SlotChar] -> Text slotRange ls = @@ -58,36 +69,40 @@ , slotChar d ] | otherwise = T.pack [slotChar c, '-', slotChar d] -allSlots :: [SlotChar] -allSlots = map SlotChar $ ['a'..'z'] ++ ['A'..'Z'] +allSlots :: Int -> [SlotChar] +allSlots n = map (SlotChar n) $ ['a'..'z'] ++ ['A'..'Z'] +allZeroSlots :: [SlotChar] +allZeroSlots = allSlots 0 + -- | Assigns a slot to an item, for inclusion in the inventory or equipment -- of a hero. Tries to to use the requested slot, if any. -assignSlot :: Item -> FactionId -> Maybe Actor -> ItemSlots -> SlotChar - -> State - -> Either SlotChar Int -assignSlot item fid mbody (letterSlots, numberSlots) lastSlot s = - if jsymbol item == '$' - then Left $ SlotChar '$' - else case free of - freeChar : _ -> Left freeChar - [] -> Right $ head freeNumbers +assignSlot :: CStore -> Item -> FactionId -> Maybe Actor -> ItemSlots + -> SlotChar -> State + -> SlotChar +assignSlot store item fid mbody (itemSlots, organSlots) lastSlot s = + assert (maybe True (\b -> bfid b == fid) mbody) + $ if jsymbol item == '$' + then SlotChar 0 '$' + else head $ fresh ++ free where - candidates = take (length allSlots) - $ drop (1 + fromJust (elemIndex lastSlot allSlots)) - $ cycle allSlots - onPerson = maybe (sharedAllOwnedFid True fid s) - (\body -> sharedAllOwned True body s) + offset = maybe 0 (+1) (elemIndex lastSlot allZeroSlots) + onlyOrgans = store == COrgan + len0 = length allZeroSlots + candidatesZero = take len0 $ drop offset $ cycle allZeroSlots + candidates = candidatesZero ++ concat [allSlots n | n <- [1..]] + onPerson = sharedAllOwnedFid onlyOrgans fid s + onGround = maybe EM.empty -- consider floor only under the acting actor + (\b -> getCBag (CFloor (blid b) (bpos b)) s) mbody - onGroud = maybe EM.empty - (\b -> getCBag (CFloor (blid b) (bpos b)) s) - mbody - inBags = ES.unions $ map EM.keysSet [onPerson, onGroud] - f l = maybe True (`ES.notMember` inBags) $ EM.lookup l letterSlots + inBags = ES.unions $ map EM.keysSet $ onPerson : [ onGround | not onlyOrgans] + lSlots = if onlyOrgans then organSlots else itemSlots + f l = maybe True (`ES.notMember` inBags) $ EM.lookup l lSlots free = filter f candidates - g l = maybe True (`ES.notMember` inBags) $ IM.lookup l numberSlots - freeNumbers = filter g [0..] + g l = l `EM.notMember` lSlots + fresh = filter g $ take ((slotPrefix lastSlot + 1) * len0) candidates -slotLabel :: Either SlotChar Int -> MU.Part -slotLabel (Left c) = MU.String [slotChar c] -slotLabel Right{} = "0" +slotLabel :: SlotChar -> MU.Part +slotLabel x = MU.String + $ (if slotPrefix x == 0 then [] else show $ slotPrefix x) + ++ [slotChar x] diff --git a/Game/LambdaHack/Client/Key.hs b/Game/LambdaHack/Client/Key.hs --- a/Game/LambdaHack/Client/Key.hs +++ b/Game/LambdaHack/Client/Key.hs @@ -3,10 +3,11 @@ module Game.LambdaHack.Client.Key ( Key(..), showKey, handleDir, dirAllKey , moveBinding, mkKM, keyTranslate - , Modifier(..), KM(..), showKM - , escKM, spaceKM, returnKM, pgupKM, pgdnKM + , Modifier(..), KM(..), toKM, showKM + , escKM, spaceKM, returnKM, pgupKM, pgdnKM, leftButtonKM, rightButtonKM ) where +import Control.DeepSeq import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.Char as Char @@ -16,6 +17,7 @@ import Prelude hiding (Left, Right) import Game.LambdaHack.Common.Msg +import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Vector -- | Frontend-independent datatype to represent keys. @@ -39,30 +41,45 @@ | Home | KP !Char -- ^ a keypad key for a character (digits and operators) | Char !Char -- ^ a single printable character + | LeftButtonPress -- ^ left mouse button pressed + | MiddleButtonPress -- ^ middle mouse button pressed + | RightButtonPress -- ^ right mouse button pressed | Unknown !Text -- ^ an unknown key, registered to warn the user deriving (Read, Ord, Eq, Generic) instance Binary Key +instance NFData Key + -- | Our own encoding of modifiers. Incomplete. data Modifier = NoModifier + | Shift | Control + | Alt deriving (Read, Ord, Eq, Generic) instance Binary Modifier -data KM = KM {modifier :: !Modifier, key :: !Key} +instance NFData Modifier + +data KM = KM { key :: !Key + , modifier :: !Modifier + , pointer :: !Point } deriving (Read, Ord, Eq, Generic) +instance NFData KM + instance Show KM where show = T.unpack . showKM instance Binary KM +toKM :: Modifier -> Key -> KM +toKM modifier key = KM{pointer=dummyPoint, ..} + -- Common and terse names for keys. showKey :: Key -> Text -showKey (Char c) = T.singleton c showKey Esc = "ESC" showKey Return = "RET" showKey Space = "SPACE" @@ -81,28 +98,40 @@ showKey Insert = "INSERT" showKey Delete = "DELETE" showKey (KP c) = "KEYPAD_" <> T.singleton c +showKey (Char c) = T.singleton c +showKey LeftButtonPress = "LEFT-BUTTON" +showKey MiddleButtonPress = "MIDDLE-BUTTON" +showKey RightButtonPress = "RIGHT-BUTTON" showKey (Unknown s) = s -- | Show a key with a modifier, if any. showKM :: KM -> Text +showKM KM{modifier=Shift, key} = "SHIFT-" <> showKey key showKM KM{modifier=Control, key} = "CTRL-" <> showKey key +showKM KM{modifier=Alt, key} = "ALT-" <> showKey key showKM KM{modifier=NoModifier, key} = showKey key escKM :: KM -escKM = KM {modifier = NoModifier, key = Esc} +escKM = toKM NoModifier Esc spaceKM :: KM -spaceKM = KM {modifier = NoModifier, key = Space} +spaceKM = toKM NoModifier Space returnKM :: KM -returnKM = KM {modifier = NoModifier, key = Return} +returnKM = toKM NoModifier Return pgupKM :: KM -pgupKM = KM {modifier = NoModifier, key = PgUp} +pgupKM = toKM NoModifier PgUp pgdnKM :: KM -pgdnKM = KM {modifier = NoModifier, key = PgDn} +pgdnKM = toKM NoModifier PgDn +leftButtonKM :: KM +leftButtonKM = toKM NoModifier LeftButtonPress + +rightButtonKM :: KM +rightButtonKM = toKM NoModifier RightButtonPress + dirKeypadKey :: [Key] dirKeypadKey = [Home, Up, PgUp, Right, PgDn, Down, End, Left] @@ -142,7 +171,7 @@ dirRunControl :: [Key] dirRunControl = dirKeypadKey ++ dirKeypadShiftKey - ++ (map Char dirKeypadShiftChar) + ++ map Char dirKeypadShiftChar dirAllKey :: Bool -> Bool -> [Key] dirAllKey configVi configLaptop = @@ -164,9 +193,9 @@ moveBinding configVi configLaptop move run = let assign f (km, dir) = (km, f dir) mapMove modifier keys = - map (assign move) (zip (zipWith KM (repeat modifier) keys) moves) + map (assign move) (zip (map (toKM modifier) keys) $ cycle moves) mapRun modifier keys = - map (assign run) (zip (zipWith KM (repeat modifier) keys) moves) + map (assign run) (zip (map (toKM modifier) keys) $ cycle moves) in mapMove NoModifier (dirMoveNoModifier configVi configLaptop) ++ mapRun NoModifier (dirRunNoModifier configVi configLaptop) ++ mapRun Control dirRunControl @@ -174,12 +203,13 @@ mkKM :: String -> KM mkKM s = let mkKey sk = case keyTranslate sk of - Unknown _ -> - assert `failure` "unknown key" `twith` s + Unknown _ -> assert `failure` "unknown key" `twith` s key -> key in case s of - ('C':'T':'R':'L':'-':rest) -> KM {key=mkKey rest, modifier=Control} - _ -> KM {key=mkKey s, modifier=NoModifier} + ('S':'H':'I':'F':'T':'-':rest) -> toKM Shift (mkKey rest) + ('C':'T':'R':'L':'-':rest) -> toKM Control (mkKey rest) + ('A':'L':'T':'-':rest) -> toKM Alt (mkKey rest) + _ -> toKM NoModifier (mkKey s) -- | Translate key from a GTK string description to our internal key type. -- To be used, in particular, for the command bindings and macros @@ -198,7 +228,8 @@ keyTranslate "asterisk" = Char '*' keyTranslate "KP_Multiply" = KP '*' keyTranslate "slash" = Char '/' -keyTranslate "KP_Divide" = Char '/' +keyTranslate "KP_Divide" = KP '/' +keyTranslate "bar" = Char '|' keyTranslate "backslash" = Char '\\' keyTranslate "underscore" = Char '_' keyTranslate "minus" = Char '-' @@ -211,6 +242,9 @@ keyTranslate "braceleft" = Char '{' keyTranslate "braceright" = Char '}' keyTranslate "ampersand" = Char '&' +keyTranslate "at" = Char '@' +keyTranslate "asciitilde" = Char '~' +keyTranslate "exclam" = Char '!' keyTranslate "apostrophe" = Char '\'' keyTranslate "Escape" = Esc keyTranslate "Return" = Return @@ -249,6 +283,9 @@ keyTranslate "Delete" = Delete keyTranslate "KP_Delete" = Delete keyTranslate "KP_Enter" = Return +keyTranslate "LeftButtonPress" = LeftButtonPress +keyTranslate "MiddleButtonPress" = MiddleButtonPress +keyTranslate "RightButtonPress" = RightButtonPress keyTranslate ['K','P','_',c] = KP c keyTranslate [c] = Char c keyTranslate s = Unknown $ T.pack s diff --git a/Game/LambdaHack/Client/LoopClient.hs b/Game/LambdaHack/Client/LoopClient.hs --- a/Game/LambdaHack/Client/LoopClient.hs +++ b/Game/LambdaHack/Client/LoopClient.hs @@ -9,7 +9,6 @@ import qualified Data.Text as T import Game.LambdaHack.Atomic -import Game.LambdaHack.Client.CommonClient import Game.LambdaHack.Client.HandleResponseClient import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.ProtocolClient @@ -46,6 +45,7 @@ Nothing -> return () return False +-- | The main game loop for an AI client. loopAI :: ( MonadAtomic m , MonadClientReadResponse ResponseAI m , MonadClientWriteRequest RequestAI m ) @@ -77,6 +77,7 @@ quit <- getsClient squit unless quit loop +-- | The main game loop for a UI client. loopUI :: ( MonadClientUI m , MonadAtomic m , MonadClientReadResponse ResponseUI m @@ -91,7 +92,7 @@ cmd1 <- receiveResponse case (restored, cmd1) of (True, RespUpdAtomicUI UpdResume{}) -> do - mode <- getModeClient + mode <- getGameMode msgAdd $ mdesc mode handleResponseUI cmd1 (True, RespUpdAtomicUI UpdRestart{}) -> do 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 @@ -11,7 +11,6 @@ import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import qualified Data.IntMap.Strict as IM import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU @@ -36,7 +35,6 @@ import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.ModeKind -- | Client state, belonging to a single faction. -- Some of the data, e.g, the history, carries over @@ -52,7 +50,7 @@ , sexplored :: !(ES.EnumSet LevelId) -- ^ the set of fully explored levels , sbfsD :: !(EM.EnumMap ActorId - ( PointArray.Array BfsDistance + ( Bool, PointArray.Array BfsDistance , Point, Int, Maybe [Point]) ) -- ^ pathfinding distances for our actors -- and paths to their targets, if any @@ -69,6 +67,7 @@ , sdiscoEffect :: !DiscoveryEffect -- ^ remembered effects&Co of items , sfper :: !FactionPers -- ^ faction perception indexed by levels , srandom :: !R.StdGen -- ^ current random generator + , slastKM :: !K.KM -- ^ last issued key command , slastRecord :: !LastRecord -- ^ state of key sequence recording , slastPlay :: ![K.KM] -- ^ state of key sequence playback , slastLost :: !(ES.EnumSet ActorId) @@ -85,7 +84,7 @@ , scurDifficulty :: !Int -- ^ current game difficulty level , sslots :: !ItemSlots -- ^ map from slots to items , slastSlot :: !SlotChar -- ^ last used slot - , sgameMode :: !(GroupName ModeKind) -- ^ current game mode + , slastStore :: !CStore -- ^ last used store , sescAI :: !EscAI -- ^ just canceled AI control with ESC , sdebugCli :: !DebugModeCli -- ^ client debugging mode } @@ -101,10 +100,10 @@ data RunParams = RunParams { runLeader :: !ActorId -- ^ the original leader from run start , runMembers :: ![ActorId] -- ^ the list of actors that take part - , runDist :: !Int -- ^ distance of the run so far - -- (plus one, if multiple runners) + , runInitial :: !Bool -- ^ initial run continuation by any + -- run participant, including run leader , runStopMsg :: !(Maybe Text) -- ^ message with the next stop reason - , runInitDir :: !(Maybe Vector) -- ^ the direction of the initial step + , runWaiting :: !Int -- ^ waiting for others to move out of the way } deriving (Show) @@ -138,6 +137,7 @@ , sdiscoEffect = EM.empty , sfper = EM.empty , srandom = R.mkStdGen 42 -- will be set later + , slastKM = K.escKM , slastRecord = ([], [], 0) , slastPlay = [] , slastLost = ES.empty @@ -150,9 +150,9 @@ , smarkSmell = True , smarkSuspect = False , scurDifficulty = difficultyDefault - , sslots = (EM.empty, IM.empty) - , slastSlot = SlotChar 'a' - , sgameMode = "starting" + , sslots = (EM.empty, EM.empty) + , slastSlot = SlotChar 0 'Z' + , slastStore = CInv , sescAI = EscAINothing , sdebugCli = defDebugModeCli } @@ -224,7 +224,7 @@ put scurDifficulty put sslots put slastSlot - put sgameMode + put slastStore put sdebugCli -- TODO: this is overwritten at once get = do stgtMode <- get @@ -250,11 +250,12 @@ scurDifficulty <- get sslots <- get slastSlot <- get - sgameMode <- get + slastStore <- get sdebugCli <- get let sbfsD = EM.empty sfper = EM.empty srandom = read g + slastKM = K.escKM slastRecord = ([], [], 0) slastPlay = [] slastLost = ES.empty @@ -267,13 +268,13 @@ put RunParams{..} = do put runLeader put runMembers - put runDist + put runInitial put runStopMsg - put runInitDir + put runWaiting get = do runLeader <- get runMembers <- get - runDist<- get + runInitial <- get runStopMsg <- get - runInitDir <- get + runWaiting <- get return $! RunParams{..} 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 @@ -13,6 +13,7 @@ -- * Operations exposed for LoopClient , ColorMode(..), displayMore, msgAdd #ifdef EXPOSE_INTERNAL + -- * Internal operations , humanCommand #endif ) where @@ -28,7 +29,6 @@ import qualified Game.LambdaHack.Client.Key as K 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.DisplayAtomicClient import Game.LambdaHack.Client.UI.HandleHumanClient @@ -36,12 +36,13 @@ import Game.LambdaHack.Client.UI.KeyBindings import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.MsgClient -import Game.LambdaHack.Client.UI.RunClient import Game.LambdaHack.Client.UI.StartupFrontendClient import Game.LambdaHack.Client.UI.WidgetClient import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Msg +import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import Game.LambdaHack.Content.ModeKind @@ -52,56 +53,30 @@ side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD let (leader, mtgt) = fromMaybe (assert `failure` fact) $ gleader fact - srunning <- getsClient srunning - -- When running, stop if disturbed. If not running, let the human - -- player issue commands, until any command takes time. - req <- case srunning of - Nothing -> humanCommand Nothing - Just RunParams{runMembers} - | noRunWithMulti fact && runMembers /= [leader] -> do - stopRunning - Config{configRunStopMsgs} <- askConfig - let msg = if configRunStopMsgs - then Just $ "Run stop: automatic leader change" - else Nothing - humanCommand msg - Just runParams -> do - runOutcome <- continueRun runParams - case runOutcome of - Left stopMsg -> do - stopRunning - Config{configRunStopMsgs} <- askConfig - let msg = if configRunStopMsgs - then Just $ "Run stop:" <+> stopMsg - else Nothing - humanCommand msg - Right (paramNew, runCmd) -> do - modifyClient $ \cli -> cli {srunning = Just paramNew} - displayPush - return $! anyToUI $ runCmd + req <- humanCommand leader2 <- getLeaderUI mtgt2 <- getsClient $ fmap fst . EM.lookup leader2 . stargetD if (leader2, mtgt2) /= (leader, mtgt) then return $! ReqUILeader leader2 mtgt2 req else return $! req --- | Determine and process the next human player command. The argument is --- the last stop message due to running, if any. -humanCommand :: forall m. MonadClientUI m - => Maybe Msg -> m RequestUI -humanCommand msgRunStop = do +-- | Let the human player issue commands until any command takes time. +humanCommand :: forall m. MonadClientUI m => m RequestUI +humanCommand = do -- For human UI we invalidate whole @sbfsD@ at the start of each - -- UI player input, which is an overkill, but doesn't affects - -- screensavers, because they are UI, but not human. + -- UI player input that start a player move, which is an overkill, + -- but doesn't slow screensavers, because they are UI, + -- but not human. modifyClient $ \cli -> cli {sbfsD = EM.empty, slastLost = ES.empty} - let loop :: Maybe (Bool, Overlay) -> m RequestUI + let loop :: Either Bool (Maybe Bool, Overlay) -> m RequestUI loop mover = do (lastBlank, over) <- case mover of - Nothing -> do - -- Display current state if no slideshow or if interrupted. - sli <- promptToSlideshow "" - return (False, head . snd $! slideshow sli) - Just bLast -> + Left b -> do + -- Display current state and keys if no slideshow or if interrupted. + keys <- if b then describeMainKeys else return "" + sli <- promptToSlideshow keys + return (Nothing, head . snd $! slideshow sli) + Right bLast -> -- (Re-)display the last slide while waiting for the next key. return bLast (seqCurrent, seqPrevious, k) <- getsClient slastRecord @@ -112,16 +87,16 @@ _ -> do let slastRecord = ([], seqCurrent ++ seqPrevious, k - 1) modifyClient $ \cli -> cli {slastRecord} + lastPlay <- getsClient slastPlay km <- getKeyOverlayCommand lastBlank over -- Messages shown, so update history and reset current report. - recordHistory + when (null lastPlay) recordHistory abortOrCmd <- do -- Look up the key. Binding{bcmdMap} <- askBinding - case M.lookup km bcmdMap of + case M.lookup km{K.pointer=dummyPoint} bcmdMap of Just (_, _, cmd) -> do -- Query and clear the last command key. - stgtMode <- getsClient stgtMode modifyClient $ \cli -> cli {swaitTimes = if swaitTimes cli > 0 then - swaitTimes cli @@ -137,11 +112,12 @@ cmdHumanSem cmd _ -> do modifyClient $ \cli -> cli {sescAI = EscAINothing} - if km == K.escKM && isNothing stgtMode && isJust mover + stgtMode <- getsClient stgtMode + if km == K.escKM && isNothing stgtMode && isRight mover then cmdHumanSem Clear else cmdHumanSem cmd Nothing -> let msgKey = "unknown command <" <> K.showKM km <> ">" - in fmap Left $ promptToSlideshow msgKey + in failWith msgKey -- The command was failed or successful and if the latter, -- possibly took some time. case abortOrCmd of @@ -154,23 +130,21 @@ -- Analyse the obtained slides. let (onBlank, sli) = slideshow slides mLast <- case sli of - [] -> return Nothing + [] -> do + stgtMode <- getsClient stgtMode + return $ Left $ isJust stgtMode || km == K.escKM [sLast] -> -- Avoid displaying the single slide twice. - return $ Just (onBlank, sLast) + return $ Right (onBlank, sLast) _ -> do -- Show, one by one, all slides, awaiting confirmation -- for all but the last one (which is displayed twice, BTW). -- Note: the code that generates the slides is responsible -- for inserting the @more@ prompt. go <- getInitConfirms ColorFull [km] slides - return $! if go then Just (onBlank, last sli) else Nothing + return $! if go then Right (onBlank, last sli) else Left True loop mLast - case msgRunStop of - Nothing -> loop Nothing - Just msg -> do - sli <- promptToSlideshow msg - loop $ Just (False, head . snd $ slideshow sli) + loop $ Left False -- | Client signals to the server that it's still online, flushes frames -- (if needed) and sends some extra info. 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 @@ -4,7 +4,8 @@ ( SingleFrame(..), decodeLine, encodeLine , overlayOverlay , Animation, Frames, renderAnim, restrictAnim - , twirlSplash, blockHit, blockMiss, deathBody, swapPlaces, fadeout + , twirlSplash, blockHit, blockMiss, deathBody, actorX + , swapPlaces, moveProj, fadeout ) where import Control.Exception.Assert.Sugar @@ -84,7 +85,7 @@ let fLine y lineOld = let f l (x, acOld) = let pos = Point x y - !ac = fromMaybe acOld $ EM.lookup pos am + !ac = EM.findWithDefault acOld pos am in ac : l in foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld)) sfLevel = -- fully evaluated inside @@ -93,13 +94,13 @@ $ foldl' f [] (zip [lysize-1,lysize-2..0] $ reverse $ map decodeLine levelOld) in Just SingleFrame{..} -- a thunk within Just - in Nothing : map (modifyFrame basicFrame) anim ++ [Nothing] + in map (modifyFrame basicFrame) anim blank :: Maybe AttrChar blank = Nothing -coloredSymbol :: Color -> Char -> Maybe AttrChar -coloredSymbol color symbol = Just $ AttrChar (Attr color defBG) symbol +cSym :: Color -> Char -> Maybe AttrChar +cSym color symbol = Just $ AttrChar (Attr color defBG) symbol mzipPairs :: (Point, Point) -> (Maybe AttrChar, Maybe AttrChar) -> [(Point, AttrChar)] @@ -111,6 +112,13 @@ -- not the action. [mzip (p1, mattr1)] +mzipTriples :: (Point, Point, Point) + -> (Maybe AttrChar, Maybe AttrChar, Maybe AttrChar) + -> [(Point, AttrChar)] +mzipTriples (p1, p2, p3) (mattr1, mattr2, mattr3) = + let mzip (pos, mattr) = fmap (\x -> (pos, x)) mattr + in catMaybes [mzip (p1, mattr1), mzip (p2, mattr2), mzip (p3, mattr3)] + restrictAnim :: ES.EnumSet Point -> Animation -> Animation restrictAnim vis (Animation as) = let f imap = @@ -118,71 +126,122 @@ in if EM.null common then Nothing else Just common in Animation $ mapMaybe f as +-- TODO: in all but moveProj duplicate first and/or last frame, if required, +-- since they are no longer duplicated in renderAnim + -- | Attack animation. A part of it also reused for self-damage and healing. twirlSplash :: (Point, Point) -> Color -> Color -> Animation twirlSplash poss c1 c2 = Animation $ map (EM.fromList . mzipPairs poss) - [ (blank , coloredSymbol BrCyan '\'') - , (blank , coloredSymbol BrYellow '^') - , (coloredSymbol c1 '/', coloredSymbol BrCyan '^') - , (coloredSymbol c1 '-', blank) - , (coloredSymbol c1 '\\',blank) - , (coloredSymbol c1 '|', blank) - , (coloredSymbol c2 '%', blank) - , (coloredSymbol c2 '/', blank) + [ (blank , cSym BrCyan '\'') + , (blank , cSym BrYellow '\'') + , (blank , cSym BrYellow '^') + , (cSym c1 '\\',cSym BrCyan '^') + , (cSym c1 '|', cSym BrCyan '^') + , (cSym c1 '%', blank) + , (cSym c1 '/', blank) + , (cSym c1 '-', blank) + , (cSym c1 '\\',blank) + , (cSym c2 '|', blank) + , (cSym c2 '%', blank) + , (cSym c2 '%', blank) + , (cSym c2 '/', blank) ] -- | Attack that hits through a block. blockHit :: (Point, Point) -> Color -> Color -> Animation blockHit poss c1 c2 = Animation $ map (EM.fromList . mzipPairs poss) - [ (blank , coloredSymbol BrCyan '\'') - , (blank , coloredSymbol BrYellow '^') - , (blank , coloredSymbol BrCyan '^') - , (coloredSymbol BrBlue '{', coloredSymbol BrYellow '\'') - , (coloredSymbol BrBlue '{', blank) - , (coloredSymbol BrBlue '}', blank) - , (coloredSymbol BrBlue '}', blank) - , (coloredSymbol c1 '\\',blank) - , (coloredSymbol c1 '|', blank) - , (coloredSymbol c2 '%', blank) - , (coloredSymbol c2 '/', blank) + [ (blank , cSym BrCyan '\'') + , (blank , cSym BrYellow '\'') + , (blank , cSym BrYellow '^') + , (blank , cSym BrCyan '^') + , (cSym BrBlue '{', cSym BrCyan '\'') + , (cSym BrBlue '{', cSym BrYellow '\'') + , (cSym BrBlue '{', cSym BrYellow '\'') + , (cSym BrBlue '}', blank) + , (cSym BrBlue '}', blank) + , (cSym BrBlue '}', blank) + , (cSym c1 '\\',blank) + , (cSym c1 '|', blank) + , (cSym c1 '/', blank) + , (cSym c1 '-', blank) + , (cSym c2 '\\',blank) + , (cSym c2 '|', blank) + , (cSym c2 '/', blank) ] -- | Attack that is blocked. blockMiss :: (Point, Point) -> Animation blockMiss poss = Animation $ map (EM.fromList . mzipPairs poss) - [ (blank , coloredSymbol BrCyan '\'') - , (coloredSymbol BrBlue '{', coloredSymbol BrYellow '^') - , (coloredSymbol BrBlue '{', blank) - , (coloredSymbol BrBlue '}', blank) - , (coloredSymbol Blue '}', blank) + [ (blank , cSym BrCyan '\'') + , (blank , cSym BrYellow '^') + , (cSym BrBlue '{', cSym BrYellow '\'') + , (cSym BrBlue '{', cSym BrCyan '\'') + , (cSym BrBlue '{', blank) + , (cSym BrBlue '}', blank) + , (cSym BrBlue '}', blank) + , (cSym Blue '}', blank) + , (cSym Blue '}', blank) ] -- | Death animation for an organic body. deathBody :: Point -> Animation deathBody pos = Animation $ map (maybe EM.empty (EM.singleton pos)) - [ coloredSymbol BrRed '\\' - , coloredSymbol BrRed '\\' - , coloredSymbol BrRed '|' - , coloredSymbol BrRed '|' - , coloredSymbol BrRed '%' - , coloredSymbol BrRed '%' - , coloredSymbol Red '%' - , coloredSymbol Red '%' - , coloredSymbol Red '%' - , coloredSymbol Red ';' - , coloredSymbol Red ';' - , coloredSymbol Red ',' + [ cSym BrRed '\\' + , cSym BrRed '\\' + , cSym BrRed '|' + , cSym BrRed '|' + , cSym BrRed '%' + , cSym BrRed '%' + , cSym BrRed '-' + , cSym BrRed '-' + , cSym BrRed '\\' + , cSym BrRed '\\' + , cSym BrRed '|' + , cSym BrRed '|' + , cSym BrRed '%' + , cSym BrRed '%' + , cSym BrRed '%' + , cSym Red '%' + , cSym Red '%' + , cSym Red '%' + , cSym Red '%' + , cSym Red ';' + , cSym Red ';' + , cSym Red ',' ] +-- | Mark actor location animation. +actorX :: Point -> Char -> Color.Color -> Animation +actorX pos symbol color = Animation $ map (maybe EM.empty (EM.singleton pos)) + [ cSym BrRed 'X' + , cSym BrRed 'X' + , cSym BrRed symbol + , cSym color symbol + , cSym color symbol + , cSym color symbol + , cSym color symbol + ] + -- | Swap-places animation, both hostile and friendly. swapPlaces :: (Point, Point) -> Animation swapPlaces poss = Animation $ map (EM.fromList . mzipPairs poss) - [ (coloredSymbol BrMagenta 'o', coloredSymbol Magenta 'o') - , (coloredSymbol BrMagenta 'd', coloredSymbol Magenta 'p') - , (coloredSymbol Magenta 'p', coloredSymbol BrMagenta 'd') - , (coloredSymbol Magenta 'o', blank) + [ (cSym BrMagenta 'o', cSym Magenta 'o') + , (cSym BrMagenta 'd', cSym Magenta 'p') + , (cSym BrMagenta '.', cSym Magenta 'p') + , (cSym Magenta 'p', cSym Magenta '.') + , (cSym Magenta 'p', cSym BrMagenta 'd') + , (cSym Magenta 'p', cSym BrMagenta 'd') + , (cSym Magenta 'o', blank) ] +moveProj :: (Point, Point, Point) -> Char -> Color.Color -> Animation +moveProj poss symbol color = Animation $ map (EM.fromList . mzipTriples poss) + [ (cSym BrBlack '.', cSym color symbol , cSym color '.') +-- , (cSym BrBlack '.', cSym BrBlack symbol, cSym color symbol) + , (cSym BrBlack '.', cSym BrBlack '.' , cSym color symbol) + , (blank , cSym BrBlack '.' , cSym color symbol) + ] + fadeout :: Bool -> Bool -> Int -> X -> Y -> Rnd Animation fadeout out topRight step lxsize lysize = do let xbound = lxsize - 1 @@ -213,5 +272,5 @@ return $! EM.fromList l startN = if out then 3 else 1 fs = [startN, startN + step .. 3 * lxsize `divUp` 4 + 2] - as <- mapM rollFrame $ if out then fs else reverse fs - return $! Animation as + as <- mapM rollFrame fs + return $! Animation $ if out then as else reverse (EM.empty : as) diff --git a/Game/LambdaHack/Client/UI/Config.hs b/Game/LambdaHack/Client/UI/Config.hs --- a/Game/LambdaHack/Client/UI/Config.hs +++ b/Game/LambdaHack/Client/UI/Config.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric, FlexibleContexts #-} -- | Personal game configuration file type definitions. module Game.LambdaHack.Client.UI.Config ( Config(..), mkConfig, applyConfigToDebug @@ -15,6 +16,7 @@ import Data.Text (Text) import qualified Data.Text as T import Game.LambdaHack.Common.ClientOptions +import GHC.Generics (Generic) import System.Directory import System.FilePath import Text.Read @@ -43,7 +45,7 @@ , configNoAnim :: !Bool , configRunStopMsgs :: !Bool } - deriving Show + deriving (Show, Generic) instance NFData Config @@ -90,8 +92,7 @@ mkConfig Kind.COps{corule} = do let stdRuleset = Kind.stdRuleset corule cfgUIName = rcfgUIName stdRuleset - commentsUIDefault = init $ map (drop 2) $ lines $ rcfgUIDefault stdRuleset -- TODO: init is a hack until Ini accepts empty files - sUIDefault = unlines commentsUIDefault + sUIDefault = rcfgUIDefault stdRuleset cfgUIDefault = either (assert `failure`) id $ Ini.parse sUIDefault dataDir <- appDataDir let userPath = dataDir cfgUIName <.> "ini" 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,6 +1,7 @@ -- | The type of key-command mappings to be used for the UI. module Game.LambdaHack.Client.UI.Content.KeyKind ( KeyKind(..) + , macroLeftButtonPress, macroShiftLeftButtonPress ) where import qualified Game.LambdaHack.Client.Key as K @@ -11,3 +12,17 @@ { rhumanCommands :: ![(K.KM, ([CmdCategory], HumanCmd))] -- ^ default client UI commands } + +macroLeftButtonPress :: HumanCmd +macroLeftButtonPress = + Macro "go to pointer for 100 steps" + [ "ALT-space", "ALT-minus" + , "SHIFT-MiddleButtonPress", "CTRL-semicolon" + , "CTRL-period", "V" ] + +macroShiftLeftButtonPress :: HumanCmd +macroShiftLeftButtonPress = + Macro "run collectively to pointer for 100 steps" + [ "ALT-space" + , "SHIFT-MiddleButtonPress", "CTRL-colon" + , "CTRL-period", "V" ] diff --git a/Game/LambdaHack/Client/UI/DisplayAtomicClient.hs b/Game/LambdaHack/Client/UI/DisplayAtomicClient.hs --- a/Game/LambdaHack/Client/UI/DisplayAtomicClient.hs +++ b/Game/LambdaHack/Client/UI/DisplayAtomicClient.hs @@ -5,9 +5,8 @@ import Control.Exception.Assert.Sugar import Control.Monad -import qualified Data.EnumSet as ES import qualified Data.EnumMap.Strict as EM -import qualified Data.IntMap.Strict as IM +import qualified Data.EnumSet as ES import Data.Maybe import Data.Monoid import Data.Tuple @@ -39,6 +38,7 @@ import Game.LambdaHack.Common.Time import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Content.TileKind as TK -- * RespUpdAtomicUI @@ -57,7 +57,7 @@ -- the client state is modified by the command. displayRespUpdAtomicUI :: MonadClientUI m => Bool -> State -> StateClient -> UpdAtomic -> m () -displayRespUpdAtomicUI verbose _oldState oldStateClient cmd = case cmd of +displayRespUpdAtomicUI verbose oldState oldStateClient cmd = case cmd of -- Create/destroy actors and items. UpdCreateActor aid body _ -> createActorUI aid body verbose "appear" UpdDestroyActor aid body _ -> do @@ -66,41 +66,46 @@ when (bfid body == side && not (bproj body)) stopPlayBack UpdCreateItem iid _ kit c -> do case c of - CActor aid COrgan -> do - let verb = - MU.Text $ "become" <+> case fst kit of - 1 -> "" - k -> tshow k <> "-fold" - -- This describes all such items already among organs, - -- which is useful, because it shows "charging". - itemAidVerbMU aid verb iid (Left Nothing) COrgan CActor aid store -> do - when (store == CGround) $ updateItemSlotSide aid iid - itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c + l <- updateItemSlotSide store aid iid + case store of + COrgan -> do + let verb = + MU.Text $ "become" <+> case fst kit of + 1 -> "" + k -> tshow k <> "-fold" + -- This describes all such items already among organs, + -- which is useful, because it shows "charging". + itemAidVerbMU aid verb iid (Left Nothing) COrgan + _ -> do + itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c + mleader <- getsClient _sleader + when (Just aid == mleader) $ + modifyClient $ \cli -> cli { slastSlot = l + , slastStore = store } CEmbed{} -> return () CFloor{} -> do - updateItemSlot Nothing iid + -- If you want an item to be assigned to @slastSlot@, create it + -- in @CActor aid CGround@, not in @CFloor@. + void $ updateItemSlot CGround Nothing iid itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c - CTrunk{} -> return () + CTrunk{} -> assert `failure` c stopPlayBack UpdDestroyItem iid _ kit c -> itemVerbMU iid kit "disappear" c UpdSpotActor aid body _ -> createActorUI aid body verbose "be spotted" UpdLoseActor aid body _ -> destroyActorUI aid body "be missing in action" "be lost" verbose UpdSpotItem iid _ kit c -> do - -- We assign slots to all items visible on the floor, - -- but some of the slots are later on recycled and then - -- we report spotting the items again. - (letterSlots, numberSlots) <- getsClient sslots - case ( lookup iid $ map swap $ EM.assocs letterSlots - , lookup iid $ map swap $ IM.assocs numberSlots ) of - (Nothing, Nothing) -> do + (itemSlots, _) <- getsClient sslots + case lookup iid $ map swap $ EM.assocs itemSlots of + Nothing -> -- never seen or would have a slot case c of - CActor aid CGround -> updateItemSlotSide aid iid - CActor{} -> return () + CActor aid store -> + -- Enemy actor fetching an item from shared stash, most probably. + void $ updateItemSlotSide store aid iid CEmbed{} -> return () CFloor lid p -> do - updateItemSlot Nothing iid + void $ updateItemSlot CGround Nothing iid scursorOld <- getsClient scursor case scursorOld of TEnemy{} -> return () -- probably too important to overwrite @@ -109,25 +114,26 @@ itemVerbMU iid kit "be spotted" c stopPlayBack CTrunk{} -> return () - _ -> return () -- seen recently (still has a slot assigned) - UpdLoseItem{} -> skip + _ -> return () -- seen already (has a slot assigned) + UpdLoseItem{} -> return () -- Move actors and items. - UpdMoveActor aid _ _ -> lookAtMove aid + UpdMoveActor aid source target -> moveActor oldState aid source target UpdWaitActor aid _ -> when verbose $ aidVerbMU aid "wait" UpdDisplaceActor source target -> displaceActorUI source target - UpdMoveItem iid k aid c1 c2 -> moveItemUI verbose iid k aid c1 c2 + UpdMoveItem iid k aid c1 c2 -> moveItemUI iid k aid c1 c2 -- Change actor attributes. - UpdAgeActor{} -> skip - UpdRefillHP _ 0 -> skip + UpdAgeActor{} -> return () + UpdRefillHP _ 0 -> return () UpdRefillHP aid n -> do when verbose $ aidVerbMU aid $ MU.Text $ (if n > 0 then "heal" else "lose") - <+> tshow (abs $ n `divUp` oneM) <> "HP" + <+> tshow (abs $ n `divUp` oneM) <> "HP" mleader <- getsClient _sleader when (Just aid == mleader) $ do b <- getsState $ getActorBody aid hpMax <- sumOrganEqpClient IK.EqpSlotAddMaxHP aid - when (bhp b == xM hpMax && hpMax > 0) $ do + when (bhp b >= xM hpMax && hpMax > 0 + && resCurrentTurn (bhpDelta b) > 0) $ do actorVerbMU aid b "recover your health fully" stopPlayBack UpdRefillCalm aid calmDelta -> @@ -141,9 +147,9 @@ when (null closeFoes) $ do -- obvious where the feeling comes from aidVerbMU aid "hear something" msgDuplicateScrap - UpdOldFidActor{} -> skip - UpdTrajectory{} -> skip - UpdColorActor{} -> skip + UpdFidImpressedActor{} -> return () + UpdTrajectory{} -> return () + UpdColorActor{} -> return () -- Change faction attributes. UpdQuitFaction fid mbody _ toSt -> quitFactionUI fid mbody toSt UpdLeadFaction fid (Just (source, _)) (Just (target, _)) -> do @@ -168,7 +174,7 @@ -- TODO: report when server changes spawner's leader; -- perhaps don't switch _sleader in HandleAtomicClient, -- compare here and switch here? too hacky? fails for AI? - UpdLeadFaction{} -> skip + UpdLeadFaction{} -> return () UpdDiplFaction fid1 fid2 _ toDipl -> do name1 <- getsState $ gname . (EM.! fid1) . sfactionD name2 <- getsState $ gname . (EM.! fid2) . sfactionD @@ -177,11 +183,11 @@ showDipl Alliance = "allied" showDipl War = "at war" msgAdd $ name1 <+> "and" <+> name2 <+> "are now" <+> showDipl toDipl <> "." - UpdTacticFaction{} -> skip + UpdTacticFaction{} -> return () UpdAutoFaction fid b -> do side <- getsClient sside when (fid == side) $ setFrontAutoYes b - UpdRecordKill{} -> skip + UpdRecordKill{} -> return () -- Alter map. UpdAlterTile{} -> when verbose $ return () -- TODO: door opens UpdAlterClear _ k -> msgAdd $ if k > 0 @@ -203,24 +209,25 @@ , "a hidden" , MU.Text $ TK.tname $ okind toTile ] msgAdd msg - UpdLearnSecrets{} -> skip - UpdSpotTile{} -> skip - UpdLoseTile{} -> skip - UpdAlterSmell{} -> skip - UpdSpotSmell{} -> skip - UpdLoseSmell{} -> skip + UpdLearnSecrets{} -> return () + UpdSpotTile{} -> return () + UpdLoseTile{} -> return () + UpdAlterSmell{} -> return () + UpdSpotSmell{} -> return () + UpdLoseSmell{} -> return () -- Assorted. - UpdTimeItem{} -> skip - UpdAgeGame{} -> skip - UpdDiscover lid p iid _ _ -> discover lid p oldStateClient iid - UpdCover{} -> skip -- don't spam when doing undo - UpdDiscoverKind lid p iid _ -> discover lid p oldStateClient iid - UpdCoverKind{} -> skip -- don't spam when doing undo - UpdDiscoverSeed lid p iid _ -> discover lid p oldStateClient iid - UpdCoverSeed{} -> skip -- don't spam when doing undo - UpdPerception{} -> skip - UpdRestart fid _ _ _ _ _ -> do - mode <- getModeClient + UpdTimeItem{} -> return () + UpdAgeGame{} -> return () + UpdDiscover c iid _ _ -> discover c oldStateClient iid + UpdCover{} -> return () -- don't spam when doing undo + UpdDiscoverKind c iid _ -> discover c oldStateClient iid + UpdCoverKind{} -> return () -- don't spam when doing undo + UpdDiscoverSeed c iid _ -> discover c oldStateClient iid + UpdCoverSeed{} -> return () -- don't spam when doing undo + UpdPerception{} -> return () + UpdRestart fid _ _ _ _ -> do + void $ tryTakeMVarSescMVar -- clear ESC-pressed from end of previous game + mode <- getGameMode msgAdd $ "New game started in" <+> mname mode <+> "mode." <+> mdesc mode -- TODO: use a vertical animation instead, e.g., roll down, -- and reveal the first frame of a new game, not blank screen. @@ -228,23 +235,24 @@ when (lengthHistory history > 1) $ fadeOutOrIn False fact <- getsState $ (EM.! fid) . sfactionD setFrontAutoYes $ isAIFact fact - UpdRestartServer{} -> skip + UpdRestartServer{} -> return () UpdResume fid _ -> do fact <- getsState $ (EM.! fid) . sfactionD setFrontAutoYes $ isAIFact fact - UpdResumeServer{} -> skip - UpdKillExit{} -> skip + UpdResumeServer{} -> return () + UpdKillExit{} -> return () UpdWriteSave -> when verbose $ msgAdd "Saving backup." UpdMsgAll msg -> msgAdd msg UpdRecordHistory _ -> recordHistory -updateItemSlotSide :: MonadClient m => ActorId -> ItemId -> m () -updateItemSlotSide aid iid = do +updateItemSlotSide :: MonadClient m + => CStore -> ActorId -> ItemId -> m SlotChar +updateItemSlotSide store aid iid = do side <- getsClient sside b <- getsState $ getActorBody aid if bfid b == side - then updateItemSlot (Just aid) iid - else updateItemSlot Nothing iid + then updateItemSlot store (Just aid) iid + else updateItemSlot store Nothing iid lookAtMove :: MonadClientUI m => ActorId -> m () lookAtMove aid = do @@ -281,7 +289,7 @@ lid <- getsState $ lidFromC c localTime <- getsState $ getLocalTime lid itemToF <- itemToFullClient - let subject = partItemWs k c lid localTime (itemToF iid kit) + let subject = partItemWs k (storeFromC c) lid localTime (itemToF iid kit) msg | k > 1 = makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes subject verb] | otherwise = makeSentence [MU.SubjectVerbSg subject verb] msgAdd msg @@ -294,28 +302,28 @@ -> ItemId -> Either (Maybe Int) Int -> CStore -> m () itemAidVerbMU aid verb iid ek cstore = do - let c = CActor aid cstore - bag <- getsState $ getCBag c + bag <- getsState $ getActorBag aid cstore -- The item may no longer be in @c@, but it was case iid `EM.lookup` bag of Nothing -> assert `failure` (aid, verb, iid, cstore) Just kit@(k, _) -> do itemToF <- itemToFullClient - lid <- getsState $ lidFromC c + body <- getsState $ getActorBody aid + let lid = blid body localTime <- getsState $ getLocalTime lid subject <- partAidLeader aid let itemFull = itemToF iid kit object = case ek of Left (Just n) -> assert (n <= k `blame` (aid, verb, iid, cstore)) - $ partItemWs n c lid localTime itemFull + $ partItemWs n cstore lid localTime itemFull Left Nothing -> - let (name, stats) = partItem c lid localTime itemFull + let (_, name, stats) = partItem cstore lid localTime itemFull in MU.Phrase [name, stats] Right n -> assert (n <= k `blame` (aid, verb, iid, cstore)) $ let itemSecret = itemNoDisco (itemBase itemFull, n) - (secretName, secretAE) = partItem c lid localTime itemSecret + (_, secretName, secretAE) = partItem cstore lid localTime itemSecret name = MU.Phrase [secretName, secretAE] nameList = if n == 1 then ["the", name] @@ -339,18 +347,12 @@ createActorUI :: MonadClientUI m => ActorId -> Actor -> Bool -> MU.Part -> m () createActorUI aid body verbose verb = do + mapM_ (\(iid, store) -> void $ updateItemSlotSide store aid iid) + (getCarriedIidCStore body) side <- getsClient sside - -- Don't spam if the actor was already visible (but, e.g., on a tile that is - -- invisible this turn (in that case move is broken down to lose+spot) - -- or on a distant tile, via teleport while the observer teleported, too). - lastLost <- getsClient slastLost - when (ES.notMember aid lastLost - && (bfid body /= side - && not (bproj body) || verbose)) $ - actorVerbMU aid body verb when (bfid body /= side) $ do fact <- getsState $ (EM.! bfid body) . sfactionD - when (not (bproj body) && isAtWar fact side) $ do + when (not (bproj body) && isAtWar fact side) $ -- Target even if nobody can aim at the enemy. Let's home in on him -- and then we can aim or melee. We set permit to False, because it's -- technically very hard to check aimability here, because we are @@ -358,47 +360,62 @@ -- into account. modifyClient $ \cli -> cli {scursor = TEnemy aid False} stopPlayBack + -- Don't spam if the actor was already visible (but, e.g., on a tile that is + -- invisible this turn (in that case move is broken down to lose+spot) + -- or on a distant tile, via teleport while the observer teleported, too). + lastLost <- getsClient slastLost + when (ES.notMember aid lastLost + && (not (bproj body) || verbose)) $ do + actorVerbMU aid body verb + animFrs <- animate (blid body) + $ actorX (bpos body) (bsymbol body) (bcolor body) + displayActorStart body animFrs lookAtMove aid destroyActorUI :: MonadClientUI m => ActorId -> Actor -> MU.Part -> MU.Part -> Bool -> m () destroyActorUI aid body verb verboseVerb verbose = do + Kind.COps{corule} <- getsState scops side <- getsClient sside - if (bfid body == side && bhp body <= 0 && not (bproj body)) then do - actorVerbMU aid body verb - void $ displayMore ColorBW "" + when (bfid body == side) $ do + let upd = ES.delete aid + modifyClient $ \cli -> cli {sselected = upd $ sselected cli} + if bfid body == side && bhp body <= 0 && not (bproj body) then do + when verbose $ actorVerbMU aid body verb + let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule + fid = bfid body + fact <- getsState $ (EM.! fid) . sfactionD + actorsAlive <- anyActorsAlive fid (Just aid) + -- TODO: deduplicate wrt Server + -- TODO; actually show the --more- prompt, but not between fadeout frames + unless (fneverEmpty (gplayer fact) + && (not actorsAlive || firstDeathEnds)) $ + void $ displayMore ColorBW "" else when verbose $ actorVerbMU aid body verboseVerb modifyClient $ \cli -> cli {slastLost = ES.insert aid $ slastLost cli} -moveItemUI :: MonadClientUI m - => Bool -> ItemId -> Int -> ActorId -> CStore -> CStore - -> m () -moveItemUI verbose iid k aid cstore1 cstore2 = do - let verb = verbCStore cstore2 - when (cstore2 == CGround) $ updateItemSlotSide aid iid - b <- getsState $ getActorBody aid - fact <- getsState $ (EM.! bfid b) . sfactionD - let underAI = isAIFact fact - mleader <- getsClient _sleader - if (cstore1 == CGround && Just aid == mleader && not underAI) then do - itemAidVerbMU aid (MU.Text verb) iid (Right k) cstore2 - localTime <- getsState $ getLocalTime (blid b) - itemToF <- itemToFullClient - (letterSlots, _) <- getsClient sslots - let c2 = CActor aid cstore2 - bag <- getsState $ getCBag c2 - let kit@(n, _) = bag EM.! iid - case lookup iid $ map swap $ EM.assocs letterSlots of - Just l -> msgAdd $ makePhrase - [ "\n" - , slotLabel $ Left l - , "-" - , partItemWs n c2 (blid b) localTime (itemToF iid kit) - , "\n" ] - Nothing -> return () - else when (cstore2 /= CGround || verbose) $ -- dropping is silent - itemAidVerbMU aid (MU.Text verb) iid (Left $ Just k) cstore2 +-- TODO: deduplicate wrt Server +anyActorsAlive :: MonadClient m => FactionId -> Maybe ActorId -> m Bool +anyActorsAlive fid maid = do + fact <- getsState $ (EM.! fid) . sfactionD + if fleaderMode (gplayer fact) /= LeaderNull + then return $! isJust $ gleader fact + else do + as <- getsState $ fidActorNotProjAssocs fid + return $! not $ null $ maybe as (\aid -> filter ((/= aid) . fst) as) maid +moveActor :: MonadClientUI m => State -> ActorId -> Point -> Point -> m () +moveActor oldState aid source target = do + lookAtMove aid + body <- getsState $ getActorBody aid + when (bproj body) $ do + let oldpos = case EM.lookup aid $ sactorD oldState of + Nothing -> assert `failure` (sactorD oldState, aid) + Just b -> boldpos b + let ps = (oldpos, source, target) + animFrs <- animate (blid body) $ moveProj ps (bsymbol body) (bcolor body) + displayActorStart body animFrs + displaceActorUI :: MonadClientUI m => ActorId -> ActorId -> m () displaceActorUI source target = do sb <- getsState $ getActorBody source @@ -414,6 +431,37 @@ animFrs <- animate (blid sb) $ swapPlaces ps displayActorStart sb animFrs +moveItemUI :: MonadClientUI m + => ItemId -> Int -> ActorId -> CStore -> CStore + -> m () +moveItemUI iid k aid cstore1 cstore2 = do + let verb = verbCStore cstore2 + b <- getsState $ getActorBody aid + fact <- getsState $ (EM.! bfid b) . sfactionD + let underAI = isAIFact fact + mleader <- getsClient _sleader + bag <- getsState $ getActorBag aid cstore2 + let kit@(n, _) = bag EM.! iid + itemToF <- itemToFullClient + (itemSlots, _) <- getsClient sslots + case lookup iid $ map swap $ EM.assocs itemSlots of + Just l -> do + when (Just aid == mleader) $ + modifyClient $ \cli -> cli { slastSlot = l + , slastStore = cstore2 } + if cstore1 == CGround && Just aid == mleader && not underAI then do + itemAidVerbMU aid (MU.Text verb) iid (Right k) cstore2 + localTime <- getsState $ getLocalTime (blid b) + msgAdd $ makePhrase + [ "\n" + , slotLabel l + , "-" + , partItemWs n cstore2 (blid b) localTime (itemToF iid kit) + , "\n" ] + else when (not (bproj b) && bhp b > 0) $ -- don't announce death drops + itemAidVerbMU aid (MU.Text verb) iid (Left $ Just k) cstore2 + Nothing -> assert `failure` (iid, itemToF iid kit) + quitFactionUI :: MonadClientUI m => FactionId -> Maybe Actor -> Maybe Status -> m () quitFactionUI fid mbody toSt = do @@ -471,8 +519,7 @@ <+> moreMsg if EM.null bag then return (mempty, 0) else do - mapM_ (updateItemSlot Nothing) $ EM.keys bag - io <- itemOverlay (CFloor (blid b) (bpos b)) (blid b) bag + io <- itemOverlay CGround (blid b) bag sli <- overlayToSlideshow itemMsg io return (sli, tot) (itemSlides, total) <- case mbody of @@ -501,29 +548,33 @@ _ -> return () discover :: MonadClientUI m - => LevelId -> Point -> StateClient -> ItemId -> m () -discover lid p oldcli iid = do + => Container -> StateClient -> ItemId -> m () +discover c oldcli iid = do + let cstore = storeFromC c + lid <- getsState $ lidFromC c cops <- getsState scops localTime <- getsState $ getLocalTime lid itemToF <- itemToFullClient - let itemFull = itemToF iid (1, []) - c = CFloor lid p - (knownName, knownAEText) = partItem c lid localTime itemFull + bag <- getsState $ getCBag c + let kit = EM.findWithDefault (1, []) iid bag + itemFull = itemToF iid kit + knownName = partItemMediumAW cstore lid localTime itemFull -- Wipe out the whole knowledge of the item to make sure the two names -- in the message differ even if, e.g., the item is described as -- "of many effects". itemSecret = itemNoDisco (itemBase itemFull, itemK itemFull) - (secretName, secretAEText) = partItem c lid localTime itemSecret + (_, secretName, secretAEText) = partItem cstore lid localTime itemSecret msg = makeSentence [ "the", MU.SubjectVerbSg (MU.Phrase [secretName, secretAEText]) "turn out to be" - , MU.AW $ MU.Phrase [knownName, knownAEText] ] + , knownName ] oldItemFull = itemToFull cops (sdiscoKind oldcli) (sdiscoEffect oldcli) iid (itemBase itemFull) (1, []) -- Compare descriptions of all aspects and effects to determine -- if the discovery was meaningful to the player. - when (textAllAE False c itemFull /= textAllAE False c oldItemFull) $ + when (textAllAE 7 False cstore itemFull + /= textAllAE 7 False cstore oldItemFull) $ msgAdd msg -- * RespSfxAtomicUI @@ -531,19 +582,21 @@ -- | Display special effects (text, animation) sent to the client. displayRespSfxAtomicUI :: MonadClientUI m => Bool -> SfxAtomic -> m () displayRespSfxAtomicUI verbose sfx = case sfx of - SfxStrike source target iid b -> strike source target iid b - SfxRecoil source target _ _ -> do + SfxStrike source target iid cstore b -> strike source target iid cstore b + SfxRecoil source target _ _ _ -> do spart <- partAidLeader source tpart <- partAidLeader target msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink away from", tpart] - SfxProject aid iid cstore -> + SfxProject aid iid cstore -> do + setLastSlot aid iid cstore itemAidVerbMU aid "aim" iid (Left $ Just 1) cstore SfxCatch aid iid cstore -> itemAidVerbMU aid "catch" iid (Left $ Just 1) cstore - SfxActivate aid iid cstore -> - itemAidVerbMU aid "activate" iid (Left $ Just 1) cstore + SfxApply aid iid cstore -> do + setLastSlot aid iid cstore + itemAidVerbMU aid "apply" iid (Left $ Just 1) cstore SfxCheck aid iid cstore -> - itemAidVerbMU aid "deactivate" iid (Left $ Just 1) cstore + itemAidVerbMU aid "deapply" iid (Left $ Just 1) cstore SfxTrigger aid _p _feat -> when verbose $ aidVerbMU aid "trigger" -- TODO: opens door, etc. SfxShun aid _p _ -> @@ -552,8 +605,9 @@ b <- getsState $ getActorBody aid side <- getsClient sside let fid = bfid b - if bhp b <= 0 && not (bproj b) || bhp b < 0 then do - -- We assume the effect is the cause of incapacitation. + if bhp b <= 0 then do + -- We assume the effect is the cause of incapacitation, but in case + -- of projectile, to reduce spam, we verify with @canKill@. let firstFall | fid == side && bproj b = "fall apart" | fid == side = "fall down" | bproj b = "break up" @@ -562,35 +616,43 @@ | fid == side = "be stomped flat" | bproj b = "be shattered into little pieces" | otherwise = "be reduced to a bloody pulp" - subject <- partActorLeader aid b - let deadPreviousTurn p = p < 0 - && (bhp b <= p && not (bproj b) - || bhp b < p) - (deadBefore, verbDie) = + -- Aspect bonuses ignored, so hurtExtra will add variety sometimes. + deadPreviousTurn dp = bhp b <= dp + harm2 dp = if deadPreviousTurn dp + then (True, Just hurtExtra) + else (False, Just firstFall) + (deadBefore, mverbDie) = case effect of - IK.Hurt p | deadPreviousTurn (xM $ Dice.maxDice p) -> - (True, hurtExtra) - IK.RefillHP p | deadPreviousTurn (xM p) -> (True, hurtExtra) - IK.OverfillHP p | deadPreviousTurn (xM p) -> (True, hurtExtra) - _ -> (False, firstFall) - msgDie = makeSentence [MU.SubjectVerbSg subject verbDie] - msgAdd msgDie - when (fid == side && not (bproj b)) $ do - animDie <- if deadBefore - then animate (blid b) - $ twirlSplash (bpos b, bpos b) Color.Red Color.Red - else animate (blid b) $ deathBody $ bpos b - displayActorStart b animDie + IK.Hurt p -> harm2 (- (xM $ Dice.maxDice p)) + IK.RefillHP p | p < 0 -> harm2 (xM p) + IK.OverfillHP p | p < 0 -> harm2 (xM p) + IK.Burn p -> harm2 (- (xM $ Dice.maxDice p)) + _ -> (False, Nothing) + case mverbDie of + Nothing -> return () -- only brutal effects work on dead/dying actor + Just verbDie -> do + subject <- partActorLeader aid b + let msgDie = makeSentence [MU.SubjectVerbSg subject verbDie] + msgAdd msgDie + when (fid == side && not (bproj b)) $ do + animDie <- if deadBefore + then animate (blid b) + $ twirlSplash (bpos b, bpos b) Color.Red Color.Red + else animate (blid b) $ deathBody $ bpos b + displayActorStart b animDie else case effect of IK.NoEffect t -> msgAdd $ "Nothing happens." <+> t - IK.Hurt{} -> skip -- avoid spam; SfxStrike just sent - IK.Burn{} -> + IK.Hurt{} -> return () -- avoid spam; SfxStrike just sent + IK.Burn{} -> do if fid == side then actorVerbMU aid b "feel burned" else actorVerbMU aid b "look burned" - IK.Explode{} -> skip -- lots of visual feedback - IK.RefillHP p | p == 1 -> skip -- no spam from regeneration + let ps = (bpos b, bpos b) + animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red + displayActorStart b animFrs + IK.Explode{} -> return () -- lots of visual feedback + IK.RefillHP p | p == 1 -> return () -- no spam from regeneration IK.RefillHP p | p > 0 -> do if fid == side then actorVerbMU aid b "feel healthier" @@ -599,7 +661,7 @@ let ps = (bpos b, bpos b) animFrs <- animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue displayActorStart b animFrs - IK.RefillHP p | p == -1 -> skip -- no spam from poison + IK.RefillHP p | p == -1 -> return () -- no spam from poison IK.RefillHP _ -> do if fid == side then actorVerbMU aid b "feel wounded" @@ -624,7 +686,7 @@ let ps = (bpos b, bpos b) animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red displayActorStart b animFrs - IK.RefillCalm p | p == 1 -> skip -- no spam from regen items + IK.RefillCalm p | p == 1 -> return () -- no spam from regen items IK.RefillCalm p | p > 0 -> do if fid == side then actorVerbMU aid b "feel calmer" @@ -661,7 +723,7 @@ -- For subsequent messages use the proper name, never "you". let subject = partActor b if fid /= fidSource then do -- before domination - if bcalm b == 0 then do -- sometimes only a coincidence, but nm + if bcalm b == 0 then -- sometimes only a coincidence, but nm aidVerbMU aid $ MU.Text "yield, under extreme pressure" else if fid == side then aidVerbMU aid $ MU.Text "black out, dominated by foes" @@ -677,49 +739,55 @@ let verb = "be now under" msgAdd $ makeSentence [MU.SubjectVerbSg subject verb, MU.Text fidSourceName, "control"] - IK.Impress{} -> + stopPlayBack + IK.Impress -> actorVerbMU aid b - $ if boldfid b /= bfid b + $ if bfidImpressed b /= bfid b then - "get refocused by the fragrant moisture" + "get calmed and refocused" +-- TODO: only show for liquids; for others say "='flash', etc. +-- "get refocused by the fragrant moisture" else - "inhale the sweet smell that weakens resolve and erodes loyalty" - IK.CallFriend{} -> skip - IK.Summon{} -> skip + "experience anxiety that weakens resolve and erodes loyalty" +-- TODO: "inhale the sweet smell that weakens resolve and erodes loyalty" + IK.CallFriend{} -> return () + IK.Summon{} -> return () IK.Ascend k | k > 0 -> actorVerbMU aid b "find a way upstairs" IK.Ascend k | k < 0 -> actorVerbMU aid b "find a way downstairs" IK.Ascend{} -> assert `failure` sfx - IK.Escape{} -> skip + IK.Escape{} -> return () IK.Paralyze{} -> actorVerbMU aid b "be paralyzed" IK.InsertMove{} -> actorVerbMU aid b "act with extreme speed" IK.Teleport t | t > 9 -> actorVerbMU aid b "teleport" IK.Teleport{} -> actorVerbMU aid b "blink" - IK.CreateItem{} -> skip - IK.DropItem COrgan _ True -> skip + IK.CreateItem{} -> return () + IK.DropItem COrgan _ True -> return () IK.DropItem _ _ False -> actorVerbMU aid b "be stripped" -- TODO IK.DropItem _ _ True -> actorVerbMU aid b "be violently stripped" - IK.PolyItem cstore -> do + IK.PolyItem -> do localTime <- getsState $ getLocalTime $ blid b - allAssocs <- fullAssocsClient aid [cstore] + allAssocs <- fullAssocsClient aid [CGround] case allAssocs of [] -> return () -- invisible items? (_, ItemFull{..}) : _ -> do + subject <- partActorLeader aid b let itemSecret = itemNoDisco (itemBase, itemK) - (secretName, secretAEText) = partItem (CActor aid cstore) (blid b) localTime itemSecret - subject = partActor b + -- TODO: plural form of secretName? only when K > 1? + -- At this point we don't easily know how many consumed. + (_, secretName, secretAEText) = partItem CGround (blid b) localTime itemSecret verb = "repurpose" - store = MU.Text $ ppCStore cstore + store = MU.Text $ ppCStoreIn CGround msgAdd $ makeSentence [ MU.SubjectVerbSg subject verb , "the", secretName, secretAEText, store ] - IK.Identify cstore -> do -- here cstore is the real location - allAssocs <- fullAssocsClient aid [cstore] + IK.Identify -> do + allAssocs <- fullAssocsClient aid [CGround] case allAssocs of [] -> return () -- invisible items? (_, ItemFull{..}) : _ -> do - let subject = partActor b - verb = "inspect" - store = MU.Text $ ppCStore cstore + subject <- partActorLeader aid b + let verb = "inspect" + store = MU.Text $ ppCStoreIn CGround msgAdd $ makeSentence [ MU.SubjectVerbSg subject verb , "an item", store ] @@ -727,10 +795,10 @@ IK.PushActor{} -> actorVerbMU aid b "be pushed" IK.PullActor{} -> actorVerbMU aid b "be pulled" IK.DropBestWeapon -> actorVerbMU aid b "be disarmed" - IK.ActivateInv{} -> skip + IK.ActivateInv{} -> return () IK.ApplyPerfume -> msgAdd "The fragrance quells all scents in the vicinity." - IK.OneOf{} -> skip + IK.OneOf{} -> return () IK.OnSmash{} -> assert `failure` sfx IK.Recharging{} -> assert `failure` sfx IK.Temporary t -> actorVerbMU aid b $ MU.Text t @@ -739,41 +807,58 @@ SfxActorStart aid -> do arena <- getArenaUI b <- getsState $ getActorBody aid - activeItems <- activeItemsClient aid +-- activeItems <- activeItemsClient aid when (blid b == arena) $ do - -- If time clip has passed since any actor advanced level time - -- or if the actor is so fast that he was capable of already moving - -- this clip (for simplicity, we don't check if he actually did) + -- If time clip has passed since any actor advanced @timeCutOff@ +--TODO -- or if the actor is so fast that he was capable of already moving +-- -- this clip (for simplicity, we don't check if he actually did) -- or if the actor is newborn or is about to die, -- we end the frame early, before his current move. -- In the result, he moves at most once per frame, and thanks to this, -- his multiple moves are not collapsed into one frame. -- If the actor changes his speed this very clip, the test can faii, -- but it's rare and results in a minor UI issue, so we don't care. + localTime <- getsState $ getLocalTime (blid b) timeCutOff <- getsClient $ EM.findWithDefault timeZero arena . sdisplayed - when (btime b >= timeShift timeCutOff (Delta timeClip) - || btime b >= timeShiftFromSpeed b activeItems timeCutOff + when (localTime >= timeShift timeCutOff (Delta timeClip) +--TODO || btime b >= timeShiftFromSpeed b activeItems timeCutOff || actorNewBorn b || actorDying b) $ do - let ageDisp displayed = EM.insert arena (btime b) displayed - modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli} - -- If considerable time passed, show delay. - let delta = btime b `timeDeltaToFrom` timeCutOff - when (delta > Delta timeClip) displayDelay -- If key will be requested, don't show the frame, because during -- the request extra message may be shown, so the other frame is better. mleader <- getsClient _sleader fact <- getsState $ (EM.! bfid b) . sfactionD let underAI = isAIFact fact - unless (Just aid == mleader && not underAI) $ + unless (Just aid == mleader && not underAI) $ do -- Something new is gonna happen on this level (otherwise we'd send -- @UpdAgeLevel@ later on, with a larger time increment), -- so show crrent game state, before it changes. - displayPush + -- If considerable time passed, show delay. TODO: do this more + -- accurately --- check if, eg., projectiles generated enough + -- frames to cover the delay and if not, add here, too. + -- Right now, if even one projectile flies, the whole 4-clip delay + -- is skipped. + let delta = localTime `timeDeltaToFrom` timeCutOff + when (delta > Delta timeClip && not (bproj b)) + displayDelay + let ageDisp = EM.insert arena localTime + modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli} + displayPush "" +setLastSlot :: MonadClientUI m => ActorId -> ItemId -> CStore -> m () +setLastSlot aid iid cstore = do + b <- getsState $ getActorBody aid + mleader <- getsClient _sleader + when (Just aid == mleader) $ do + (itemSlots, _) <- getsClient sslots + case lookup iid $ map swap $ EM.assocs itemSlots of + Just l -> modifyClient $ \cli -> cli { slastSlot = l + , slastStore = cstore } + Nothing -> assert `failure` (iid, cstore, aid, b) + strike :: MonadClientUI m - => ActorId -> ActorId -> ItemId -> HitAtomic -> m () -strike source target iid hitStatus = assert (source /= target) $ do + => ActorId -> ActorId -> ItemId -> CStore -> HitAtomic -> m () +strike source target iid cstore hitStatus = assert (source /= target) $ do itemToF <- itemToFullClient sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target @@ -781,24 +866,28 @@ tpart <- partActorLeader target tb spronoun <- partPronounLeader source sb localTime <- getsState $ getLocalTime (blid sb) - -- We don't show the charging status in the weapon strike message. Succinct. - let itemFull = itemToF iid (1, []) + bag <- getsState $ getActorBag source cstore + let kit = EM.findWithDefault (1, []) iid bag + itemFull = itemToF iid kit verb = case itemDisco itemFull of Nothing -> "hit" -- not identified Just ItemDisco{itemKind} -> IK.iverbHit itemKind isOrgan = iid `EM.member` borgan sb partItemChoice = if isOrgan - then partItemWownW spronoun (CActor source COrgan) (blid sb) localTime - -- The @CEqp@ store may be fake, but it results in an item description - -- for an active item, which is the right one for a weapon. - else partItemAW (CActor source CEqp) (blid sb) localTime + then partItemWownW spronoun COrgan (blid sb) localTime + else partItemAW cstore (blid sb) localTime msg HitClear = makeSentence $ [MU.SubjectVerbSg spart verb, tpart] ++ if bproj sb then [] else ["with", partItemChoice itemFull] msg (HitBlock n) = + -- This sounds funny when the victim falls down immediately, + -- but there is no easy way to prevent that. And it's consistent. + -- If/when death blow instead sets HP to 1 and only the next below 1, + -- we can check here for HP==1; also perhaps actors with HP 1 should + -- not be able to block. let sActs = if bproj sb then [ MU.SubjectVerbSg spart "connect" ] diff --git a/Game/LambdaHack/Client/UI/DrawClient.hs b/Game/LambdaHack/Client/UI/DrawClient.hs --- a/Game/LambdaHack/Client/UI/DrawClient.hs +++ b/Game/LambdaHack/Client/UI/DrawClient.hs @@ -8,9 +8,9 @@ import Control.Exception.Assert.Sugar import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import qualified Data.IntMap.Strict as IM import Data.List import Data.Maybe +import Data.Ord import Data.Text (Text) import qualified Data.Text as T @@ -19,6 +19,7 @@ import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.Animation +import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor as Actor import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color @@ -35,6 +36,7 @@ import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray +import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time @@ -54,12 +56,12 @@ -- to the frontends to display separately or overlay over map, -- depending on the frontend. draw :: MonadClient m - => Bool -> ColorMode -> LevelId + => ColorMode -> LevelId -> Maybe Point -> Maybe Point -> Maybe (PointArray.Array BfsDistance, Maybe [Point]) -> (Text, Maybe Text) -> (Text, Maybe Text) -> Overlay -> m SingleFrame -draw sfBlank dm drawnLevelId cursorPos tgtPos bfsmpathRaw +draw dm drawnLevelId cursorPos tgtPos bfsmpathRaw (cursorDesc, mcursorHP) (targetDesc, mtargetHP) sfTop = do cops <- getsState scops mleader <- getsClient _sleader @@ -95,12 +97,9 @@ let tile = lvl `at` pos0 tk = tokind tile floorBag = EM.findWithDefault EM.empty pos0 $ lfloor lvl - (letterSlots, numberSlots) = sslots cli - bagLetterSlots = EM.filter (`EM.member` floorBag) letterSlots - bagNumberSlots = IM.filter (`EM.member` floorBag) numberSlots - floorIids = reverse (EM.elems bagLetterSlots) - ++ IM.elems bagNumberSlots - ++ EM.keys floorBag + (itemSlots, _) = sslots cli + bagItemSlots = EM.filter (`EM.member` floorBag) itemSlots + floorIids = EM.elems bagItemSlots -- first slot will be shown sml = EM.findWithDefault timeZero pos0 lsmell smlt = sml `timeDeltaToFrom` ltime viewActor aid Actor{bsymbol, bcolor, bhp, bproj} @@ -133,7 +132,7 @@ && (elem pos0 bl || elem pos0 shiftedBTrajectory) -> ('*', atttrOnPathOrLine) -- line takes precedence over path _ | isJust stgtMode - && (maybe False (elem pos0) mpath) -> + && maybe False (elem pos0) mpath -> (';', Color.defAttr {Color.fg = fgOnPathOrLine}) Just (aid, m) -> viewActor aid m _ | smarkSmell && sml > ltime -> @@ -180,7 +179,7 @@ in fits <> ellipsis cursorText = let n = widthTgt - T.length pathCsr - 8 - in (if isJust stgtMode then "cursor>" else "Cursor:") + in (if isJust stgtMode then "x-hair>" else "X-hair:") <+> trimTgtDesc n cursorDesc cursorGap = T.replicate (widthTgt - T.length pathCsr - T.length cursorText) " " @@ -218,6 +217,7 @@ sfLevel = -- fully evaluated let f l y = let !line = fLine y in line : l in foldl' f [] [lysize-1,lysize-2..0] + sfBlank = False return $! SingleFrame{..} inverseVideo :: Color.Attr @@ -264,17 +264,17 @@ -- 'wait' command. slashes = ["/", "|", "\\", "|"] slashPick = slashes !! (max 0 (waitT - 1) `mod` length slashes) - checkDelta ResDelta{..} = - if resCurrentTurn < 0 || resPreviousTurn < 0 - then addColor Color.BrRed -- alarming news have priority - else if resCurrentTurn > 0 || resPreviousTurn > 0 - then addColor Color.BrGreen - else addAttr -- only if nothing at all noteworthy + checkDelta ResDelta{..} + | resCurrentTurn < 0 || resPreviousTurn < 0 + = addColor Color.BrRed -- alarming news have priority + | resCurrentTurn > 0 || resPreviousTurn > 0 + = addColor Color.BrGreen + | otherwise = addAttr -- only if nothing at all noteworthy calmAddAttr = checkDelta calmDelta darkPick | darkL = "." | otherwise = ":" calmHeader = calmAddAttr $ calmHeaderText <> darkPick - calmText = bcalmS <> (if darkL then slashPick else "/") <> acalmS + calmText = bcalmS <> (if darkL then slashPick else "/") <> acalmS bracePick | bracedL = "}" | otherwise = ":" hpAddAttr = checkDelta hpDelta @@ -292,12 +292,24 @@ (T.unpack t) stats <- case mleader of Just leader -> do + actorSk <- actorSkillsClient leader + b <- getsState $ getActorBody leader + localTime <- getsState $ getLocalTime (blid b) allAssocs <- fullAssocsClient leader [CEqp, COrgan] let activeItems = map snd allAssocs - damage = case strongestSlotNoFilter IK.EqpSlotWeapon allAssocs of - (_, (_, itemFull)) : _-> + calm10 = calmEnough10 b $ map snd allAssocs + forced = assert (not $ bproj b) False + permitted = permittedPrecious calm10 forced + preferredPrecious = either (const False) id . permitted + strongest = strongestMelee False localTime allAssocs + strongestPreferred = filter (preferredPrecious . snd . snd) strongest + damage = case strongestPreferred of + _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> "0" + [] -> "0" + (_average, (_, itemFull)) : _ -> let getD :: IK.Effect -> Maybe Dice.Dice -> Maybe Dice.Dice - getD (IK.Hurt dice) _ = Just dice + getD (IK.Hurt dice) acc = Just $ dice + fromMaybe 0 acc + getD (IK.Burn dice) acc = Just $ dice + fromMaybe 0 acc getD _ acc = acc mdice = case itemDisco itemFull of Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} -> @@ -316,7 +328,6 @@ <> tshow bonus <> if unknownBonus then "%?" else "%" in tdice <> tbonus - [] -> "0" return $! damage Nothing -> return "" return $! if T.null stats || T.length stats >= width then [] @@ -328,28 +339,24 @@ mleader <- getsClient _sleader selected <- getsClient sselected side <- getsClient sside - s <- getState - let viewOurs (aid, Actor{bsymbol, bcolor, bhp}) - | otherwise = - let cattr = Color.defAttr {Color.fg = bcolor} - sattr - | Just aid == mleader = inverseVideo - | ES.member aid selected = - -- TODO: in the future use a red rectangle instead - -- of background and mark them on the map, too; - -- also, perhaps blink all selected on the map, - -- when selection changes - if bcolor /= Color.Blue - then cattr {Color.bg = Color.Blue} - else cattr {Color.bg = Color.Magenta} - | otherwise = cattr - in ( (bhp > 0, bsymbol /= '@', bsymbol, bcolor, aid) - , Color.AttrChar sattr $ if bhp > 0 then bsymbol else '%' ) - ours = filter (not . bproj . snd) - $ actorAssocs (== side) drawnLevelId s + allOurs <- getsState $ filter ((== side) . bfid) . EM.elems . sactorD + ours <- getsState $ filter (not . bproj . snd) + . actorAssocs (== side) drawnLevelId + let viewOurs (aid, Actor{bsymbol, bcolor, bhp}) = + let cattr = Color.defAttr {Color.fg = bcolor} + sattr + | Just aid == mleader = inverseVideo + | ES.member aid selected = + -- TODO: in the future use a red rectangle instead + -- of background and mark them on the map, too; + -- also, perhaps blink all selected on the map, + -- when selection changes + if bcolor /= Color.Blue + then cattr {Color.bg = Color.Blue} + else cattr {Color.bg = Color.Magenta} + | otherwise = cattr + in Color.AttrChar sattr $ if bhp > 0 then bsymbol else '%' maxViewed = width - 2 - -- Don't show anything if the only actor on the level is the leader. - -- He's clearly highlighted on the level map, anyway. star = let sattr = case ES.size selected of 0 -> Color.defAttr {Color.fg = Color.BrBlack} n | n == length ours -> @@ -357,12 +364,14 @@ _ -> Color.defAttr char = if length ours > maxViewed then '$' else '*' in Color.AttrChar sattr char - viewed = take maxViewed $ sort $ map viewOurs ours + viewed = map viewOurs $ take maxViewed + $ sortBy (comparing keySelected) ours addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t) - allOurs = filter ((== side) . bfid) $ EM.elems $ sactorD s - party = if length allOurs <= 1 + -- Don't show anything if the only actor in the dungeon is the leader. + -- He's clearly highlighted on the level map, anyway. + party = if length allOurs == 1 && length ours == 1 || length ours == 0 then [] - else [star] ++ map snd viewed ++ addAttr " " + else [star] ++ viewed ++ addAttr " " return $! party drawPlayerName :: MonadClient m => Int -> m [Color.AttrChar] 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 @@ -1,7 +1,7 @@ -- | 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. + ( -- * Connection types FrontReq(..), ChanFrontend(..) -- * Re-exported part of the raw frontend , frontendName @@ -16,21 +16,24 @@ import qualified Data.Text.IO as T import System.IO +import Data.Maybe import qualified Game.LambdaHack.Client.Key as K import Game.LambdaHack.Client.UI.Animation import Game.LambdaHack.Client.UI.Frontend.Chosen import Game.LambdaHack.Common.ClientOptions +import Game.LambdaHack.Common.Point +-- | The instructions sent by clients to the raw frontend over a channel. data FrontReq = FrontNormalFrame {frontFrame :: !SingleFrame} -- ^ show a frame - | FrontRunningFrame {frontFrame :: !SingleFrame} - -- ^ show a frame in running mode (don't insert delay between frames) | FrontDelay -- ^ perform a single explicit delay | FrontKey {frontKM :: ![K.KM], frontFr :: !SingleFrame} -- ^ flush frames, possibly show fadeout/fadein and ask for a keypress - | FrontSlides {frontClear :: ![K.KM], frontSlides :: ![SingleFrame]} + | FrontSlides { frontClear :: ![K.KM] + , frontSlides :: ![SingleFrame] + , frontFromTop :: !(Maybe Bool) } -- ^ show a whole slideshow without interleaving with other clients | FrontAutoYes !Bool -- ^ set the frontend option for auto-answering prompts @@ -44,8 +47,12 @@ , requestF :: !(STM.TQueue FrontReq) } -startupF :: DebugModeCli - -> (Maybe (MVar ()) -> (ChanFrontend -> IO ()) -> IO ()) +-- | Initialize the frontend and apply the given continuation to the results +-- of the initialization. +startupF :: DebugModeCli -- ^ debug settings + -> (Maybe (MVar ()) + -> (ChanFrontend -> IO ()) + -> IO ()) -- ^ continuation -> IO () startupF dbg cont = (if sfrontendNull dbg then nullStartup @@ -63,25 +70,19 @@ promptGetKey fs [] frame = fpromptGetKey fs frame promptGetKey fs keys frame = do km <- fpromptGetKey fs frame - if km `elem` keys + if km{K.pointer=dummyPoint} `elem` keys then return km else promptGetKey fs keys frame -getConfirmGeneric :: Bool -> RawFrontend -> [K.KM] -> SingleFrame - -> IO (Maybe Bool) +getConfirmGeneric :: Bool -> RawFrontend -> [K.KM] -> SingleFrame -> IO K.KM getConfirmGeneric autoYes fs clearKeys frame = do let DebugModeCli{sdisableAutoYes} = fdebugCli fs if autoYes && not sdisableAutoYes then do - fdisplay fs True (Just frame) - return $ Just True + fdisplay fs (Just frame) + return K.spaceKM else do let extraKeys = [K.spaceKM, K.escKM, K.pgupKM, K.pgdnKM] - km <- promptGetKey fs (clearKeys ++ extraKeys) frame - return $! if km == K.escKM - then Nothing - else if km == K.pgupKM - then Just False - else Just True + promptGetKey fs (clearKeys ++ extraKeys) frame -- Read UI requests from the client and send them to the frontend, loopFrontend :: RawFrontend -> ChanFrontend -> IO () @@ -95,13 +96,10 @@ efr <- STM.atomically $ STM.readTQueue requestF case efr of FrontNormalFrame{..} -> do - fdisplay fs False (Just frontFrame) - loop autoYes - FrontRunningFrame{..} -> do - fdisplay fs True (Just frontFrame) + fdisplay fs (Just frontFrame) loop autoYes FrontDelay -> do - fdisplay fs False Nothing + fdisplay fs Nothing loop autoYes FrontKey{..} -> do km <- promptGetKey fs frontKM frontFr @@ -116,18 +114,25 @@ let displayFrs frs srf = case frs of [] -> assert `failure` "null slides" `twith` frs - [x] -> do - fdisplay fs False (Just x) + [x] | isNothing frontFromTop -> do + fdisplay fs (Just x) writeKM K.spaceKM x : xs -> do - go <- getConfirmGeneric autoYes fs frontClear x - case go of - Nothing -> writeKM K.escKM - Just True -> displayFrs xs (x : srf) - Just False -> case srf of + K.KM{..} <- getConfirmGeneric autoYes fs frontClear x + case key of + K.Esc -> writeKM K.escKM + K.PgUp -> case srf of [] -> displayFrs frs srf y : ys -> displayFrs (y : frs) ys - displayFrs frontSlides [] + K.Space -> case xs of + [] -> writeKM K.escKM -- hack + _ -> displayFrs xs (x : srf) + _ -> case xs of -- K.PgDn and any other permitted key + [] -> displayFrs frs srf + _ -> displayFrs xs (x : srf) + case (frontFromTop, reverse frontSlides) of + (Just False, r : rs) -> displayFrs [r] rs + _ -> displayFrs frontSlides [] loop autoYes FrontAutoYes b -> loop b 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 @@ -26,7 +26,7 @@ frontendName = Chosen.frontendName data RawFrontend = RawFrontend - { fdisplay :: Bool -> Maybe SingleFrame -> IO () + { fdisplay :: Maybe SingleFrame -> IO () , fpromptGetKey :: SingleFrame -> IO K.KM , fsyncFrames :: IO () , fescMVar :: !(Maybe (MVar ())) @@ -36,7 +36,7 @@ chosenStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO () chosenStartup fdebugCli cont = Chosen.startup fdebugCli $ \fs -> - cont $ RawFrontend + cont RawFrontend { fdisplay = Chosen.fdisplay fs , fpromptGetKey = Chosen.fpromptGetKey fs , fsyncFrames = Chosen.fsyncFrames fs @@ -47,7 +47,7 @@ stdStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO () stdStartup fdebugCli cont = Std.startup fdebugCli $ \fs -> - cont $ RawFrontend + cont RawFrontend { fdisplay = Std.fdisplay fs , fpromptGetKey = Std.fpromptGetKey fs , fsyncFrames = Std.fsyncFrames fs @@ -59,8 +59,8 @@ nullStartup fdebugCli cont = -- Std used to fork (async) the server thread, to avoid bound thread overhead. Std.startup fdebugCli $ \_ -> - cont $ RawFrontend - { fdisplay = \_ _ -> return () + cont RawFrontend + { fdisplay = \_ -> return () , fpromptGetKey = \_ -> return K.escKM , fsyncFrames = return () , fescMVar = Nothing 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 @@ -61,11 +61,10 @@ -- | Output to the screen via the frontend. fdisplay :: FrontendSession -- ^ frontend session data - -> Bool -> Maybe SingleFrame -- ^ the screen frame to draw -> IO () -fdisplay _ _ Nothing = return () -fdisplay FrontendSession{..} _ (Just rawSF) = do +fdisplay _ Nothing = return () +fdisplay FrontendSession{..} (Just rawSF) = do let SingleFrame{sfLevel} = overlayOverlay rawSF -- let defaultStyle = C.defaultCursesStyle -- Terminals with white background require this: @@ -93,11 +92,11 @@ -- | Display a prompt, wait for any key. fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM fpromptGetKey sess frame = do - fdisplay sess True $ Just frame + fdisplay sess $ Just frame nextEvent keyTranslate :: C.Key -> K.KM -keyTranslate e = (\(key, modifier) -> K.KM {..}) $ +keyTranslate e = (\(key, modifier) -> K.toKM modifier key) $ case e of C.KeyChar '\ESC' -> (K.Esc, K.NoModifier) C.KeyExit -> (K.Esc, K.NoModifier) 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 @@ -15,7 +15,6 @@ import Control.Concurrent.Async import qualified Control.Concurrent.STM as STM import qualified Control.Exception as Ex hiding (handle) -import Control.Exception.Assert.Sugar import Control.Monad import Control.Monad.Reader import qualified Data.ByteString.Char8 as BS @@ -33,6 +32,7 @@ import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.LQueue +import Game.LambdaHack.Common.Point data FrameState = FPushed -- frames stored in a queue, to be drawn in equal time intervals @@ -79,7 +79,7 @@ case fs of FPushed{..} -> putMVar sframeState FPushed{fpushed = f fpushed, ..} - _ -> + FNone -> putMVar sframeState fs -- | The name of the frontend. @@ -101,7 +101,7 @@ unsafeInitGUIForThreadedRTS -- Text attributes. ttt <- textTagTableNew - stags <- fmap M.fromList $ + stags <- M.fromList <$> mapM (\ ak -> do tt <- textTagNew Nothing textTagTableAdd ttt tt @@ -116,7 +116,7 @@ textViewSetEditable sview False textViewSetCursorVisible sview False -- Set up the channel for keyboard input. - schanKey <- STM.atomically $ STM.newTQueue + schanKey <- STM.atomically STM.newTQueue -- Set up the frame state. let frameState = FNone -- Create the session record. @@ -131,6 +131,9 @@ -- Fork the thread that periodically draws a frame from a queue, if any. aPoll <- async $ pollFramesAct sess `Ex.finally` postGUISync mainQuit link aPoll + let flushChanKey = do + res <- STM.atomically $ STM.tryReadTQueue schanKey + when (isJust res) flushChanKey -- Fill the keyboard channel. sview `on` keyPressEvent $ do n <- eventKeyName @@ -140,28 +143,37 @@ #else let !key = K.keyTranslate n #endif - !modifier = modifierTranslate mods - readAll = do - res <- STM.atomically $ STM.tryReadTQueue schanKey - when (isJust res) $ readAll + !modifier = let md = modifierTranslate mods + in if md == K.Shift then K.NoModifier else md + !pointer = dummyPoint liftIO $ do unless (deadKey n) $ do -- If ESC, also mark it specially and reset the key channel. when (key == K.Esc) $ do void $ tryPutMVar escMVar () - readAll + flushChanKey -- Store the key in the channel. - STM.atomically $ STM.writeTQueue schanKey K.KM{key, modifier} + STM.atomically $ STM.writeTQueue schanKey K.KM{..} return True -- Set the font specified in config, if any. f <- fontDescriptionFromString $ fromMaybe "" sfont widgetModifyFont sview (Just f) + liftIO $ do + textViewSetLeftMargin sview 3 + textViewSetRightMargin sview 3 -- Prepare font chooser dialog. currentfont <- newIORef f + Just display <- displayGetDefault + -- TODO: change cursor depending on targeting mode, etc.; hard + cursor <- cursorNewForDisplay display Tcross -- Target Crosshair Arrow sview `on` buttonPressEvent $ do + liftIO flushChanKey but <- eventButton - liftIO $ case but of - RightButton -> do + (wx, wy) <- eventCoordinates + mods <- eventModifier + let !modifier = modifierTranslate mods -- Shift included + liftIO $ do + when (but == RightButton && modifier == K.Control) $ do fsd <- fontSelectionDialogNew ("Choose font" :: String) cf <- readIORef currentfont fds <- fontDescriptionToString cf @@ -177,8 +189,28 @@ widgetModifyFont sview (Just fd) Nothing -> return () widgetDestroy fsd - return True - _ -> return False + -- We shouldn't pass on the click if the user has selected something. + hasSelection <- textBufferHasSelection tb + unless hasSelection $ do + mdrawWin <- displayGetWindowAtPointer display + let setCursor (drawWin, _, _) = + drawWindowSetCursor drawWin (Just cursor) + maybe (return ()) setCursor mdrawWin + (bx, by) <- + textViewWindowToBufferCoords sview TextWindowText + (round wx, round wy) + (iter, _) <- textViewGetIterAtPosition sview bx by + cx <- textIterGetLineOffset iter + cy <- textIterGetLine iter + let !key = case but of + LeftButton -> K.LeftButtonPress + MiddleButton -> K.MiddleButtonPress + RightButton -> K.RightButtonPress + _ -> K.LeftButtonPress + !pointer = Point cx (cy - 1) + -- Store the mouse even coords in the keypress channel. + STM.atomically $ STM.writeTQueue schanKey K.KM{..} + return $! but == RightButton -- not to disable selection -- Modify default colours. let black = Color minBound minBound minBound -- Color.defBG == Color.Black white = Color 0xC500 0xBC00 0xB800 -- Color.defFG == Color.White @@ -244,7 +276,7 @@ microInSec = 1000000 defaultMaxFps :: Int -defaultMaxFps = 15 +defaultMaxFps = 30 -- | Poll the frame queue often and draw frames at fixed intervals. pollFramesWait :: FrontendSession -> ClockTime -> IO () @@ -300,7 +332,7 @@ -- (otherwise it would change the state), so poll often. threadDelay $ microInSec `div` maxPolls maxFps pollFramesAct sess - _ -> do + FNone -> do putMVar sframeState fs -- Not in the Push state, so poll lazily to catch the next state change. -- The slow polling also gives the game logic a head start @@ -311,8 +343,8 @@ -- | Add a game screen frame to the frame drawing channel, or show -- it ASAP if @immediate@ display is requested and the channel is empty. -pushFrame :: FrontendSession -> Bool -> Bool -> Maybe SingleFrame -> IO () -pushFrame sess noDelay immediate rawFrame = do +pushFrame :: FrontendSession -> Bool -> Maybe SingleFrame -> IO () +pushFrame sess immediate rawFrame = do let FrontendSession{sframeState, slastFull} = sess -- Full evaluation is done outside the mvar locks. let !frame = case rawFrame of @@ -329,24 +361,27 @@ case fs of FPushed{..} -> putMVar sframeState - $ if isNothing nextFrame && anyFollowed + $ if isNothing nextFrame && anyFollowed && isJust rawFrame then fs -- old news else FPushed{fpushed = writeLQueue fpushed nextFrame, ..} FNone | immediate -> do -- If the frame not repeated, draw it. - maybe skip (postGUIAsync . output sess) nextFrame + maybe (return ()) (postGUIAsync . output sess) nextFrame -- Frame sent, we may now safely release the queue lock. putMVar sframeState FNone FNone -> - -- Never start playing with an empty frame. - let fpushed = if isJust nextFrame - then writeLQueue newLQueue nextFrame - else newLQueue - fshown = dummyFrame - in putMVar sframeState FPushed{..} + putMVar sframeState + $ if isNothing nextFrame && anyFollowed && isJust rawFrame + then fs -- old news + else FPushed{ fpushed = writeLQueue newLQueue nextFrame + , fshown = dummyFrame } case nextFrame of - Nothing -> putMVar slastFull (lastFrame, True) - Just f -> putMVar slastFull (f, noDelay) + Nothing -> putMVar slastFull (lastFrame, not (case fs of + FNone -> True + FPushed{} -> False + && immediate + && not anyFollowed)) + Just f -> putMVar slastFull (f, False) evalFrame :: FrontendSession -> SingleFrame -> GtkFrame evalFrame FrontendSession{stags} rawSF = @@ -379,7 +414,7 @@ then Nothing -- no sense repeating else Just frame -- Draw the last frame ASAP. - maybe skip (postGUIAsync . output sess) nextFrame + maybe (return ()) (postGUIAsync . output sess) nextFrame Nothing -> return () FNone -> return () -- Wipe out the frame queue. Release the lock. @@ -387,10 +422,9 @@ -- | Add a frame to be drawn. fdisplay :: FrontendSession -- ^ frontend session data - -> Bool -> Maybe SingleFrame -- ^ the screen frame to draw -> IO () -fdisplay sess noDelay = pushFrame sess noDelay False +fdisplay sess = pushFrame sess False -- Display all queued frames, synchronously. displayAllFramesSync :: FrontendSession -> FrameState -> IO () @@ -417,7 +451,7 @@ Nothing -> -- The queue is empty. return () - _ -> + FNone -> -- Not in Push state to start with. return () @@ -433,7 +467,7 @@ fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM fpromptGetKey sess@FrontendSession{..} frame = do - pushFrame sess True True $ Just frame + pushFrame sess True $ Just frame km <- STM.atomically $ STM.readTQueue schanKey case km of K.KM{key=K.Space} -> @@ -470,24 +504,27 @@ -- | Translates modifiers to our own encoding. modifierTranslate :: [Modifier] -> K.Modifier -modifierTranslate mods = - if Control `elem` mods then K.Control else K.NoModifier +modifierTranslate mods + | Control `elem` mods = K.Control + | any (`elem` mods) [Meta, Super, Alt, Alt2, Alt3, Alt4, Alt5] = K.Alt + | Shift `elem` mods = K.Shift + | otherwise = K.NoModifier doAttr :: DebugModeCli -> TextTag -> Color.Attr -> IO () doAttr sdebugCli tt attr@Color.Attr{fg, bg} | attr == Color.defAttr = return () - | fg == Color.defFG = set tt $ extraAttr sdebugCli - ++ [textTagBackground := Color.colorToRGB bg] - | bg == Color.defBG = set tt $ extraAttr sdebugCli - ++ [textTagForeground := Color.colorToRGB fg] - | otherwise = set tt $ extraAttr sdebugCli - ++ [ textTagForeground := Color.colorToRGB fg - , textTagBackground := Color.colorToRGB bg ] + | fg == Color.defFG = + set tt $ extraAttr sdebugCli + ++ [textTagBackground := Color.colorToRGB bg] + | bg == Color.defBG = + set tt $ extraAttr sdebugCli + ++ [textTagForeground := Color.colorToRGB fg] + | otherwise = + set tt $ extraAttr sdebugCli + ++ [ textTagForeground := Color.colorToRGB fg + , textTagBackground := Color.colorToRGB bg ] extraAttr :: DebugModeCli -> [AttrOp TextTag] extraAttr DebugModeCli{scolorIsBold} = - if scolorIsBold == Just True - then [ textTagWeight := fromEnum WeightBold + [textTagWeight := fromEnum WeightBold | scolorIsBold == Just True] -- , textTagStretch := StretchUltraExpanded - ] - else [] diff --git a/Game/LambdaHack/Client/UI/Frontend/Std.hs b/Game/LambdaHack/Client/UI/Frontend/Std.hs --- a/Game/LambdaHack/Client/UI/Frontend/Std.hs +++ b/Game/LambdaHack/Client/UI/Frontend/Std.hs @@ -39,11 +39,10 @@ -- | Output to the screen via the frontend. fdisplay :: FrontendSession -- ^ frontend session data - -> Bool -> Maybe SingleFrame -- ^ the screen frame to draw -> IO () -fdisplay _ _ Nothing = return () -fdisplay _ _ (Just rawSF) = +fdisplay _ Nothing = return () +fdisplay _ (Just rawSF) = let SingleFrame{sfLevel} = overlayOverlay rawSF bs = map (BS.pack . map Color.acChar . decodeLine) sfLevel ++ [BS.empty] in mapM_ BS.putStrLn bs @@ -63,11 +62,11 @@ -- | Display a prompt, wait for any key. fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM fpromptGetKey sess frame = do - fdisplay sess True $ Just frame + fdisplay sess $ Just frame nextEvent keyTranslate :: Char -> K.KM -keyTranslate e = (\(key, modifier) -> K.KM {..}) $ +keyTranslate e = (\(key, modifier) -> K.toKM modifier key) $ case e of '\ESC' -> (K.Esc, K.NoModifier) '\n' -> (K.Return, K.NoModifier) 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 @@ -10,19 +10,20 @@ import Control.Concurrent import Control.Concurrent.Async +import qualified Control.Concurrent.STM as STM import qualified Control.Exception as Ex hiding (handle) +import Control.Monad import Data.Default +import Data.Maybe import Graphics.Vty import qualified Graphics.Vty as Vty -import qualified Control.Concurrent.STM as STM -import Control.Monad -import Data.Maybe import qualified Game.LambdaHack.Client.Key as K import Game.LambdaHack.Client.UI.Animation import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Msg +import Game.LambdaHack.Common.Point -- | Session data maintained by the frontend. data FrontendSession = FrontendSession @@ -41,7 +42,7 @@ startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO () startup sdebugCli k = do svty <- mkVty def - schanKey <- STM.atomically $ STM.newTQueue + schanKey <- STM.atomically STM.newTQueue escMVar <- newEmptyMVar let sess = FrontendSession{sescMVar = Just escMVar, ..} void $ async $ storeKeys sess @@ -55,28 +56,28 @@ EvKey n mods -> do let !key = keyTranslate n !modifier = modifierTranslate mods + !pointer = dummyPoint readAll = do res <- STM.atomically $ STM.tryReadTQueue schanKey - when (isJust res) $ readAll + when (isJust res) readAll -- If ESC, also mark it specially and reset the key channel. case sescMVar of - Just escMVar -> do + Just escMVar -> when (key == K.Esc) $ do void $ tryPutMVar escMVar () readAll Nothing -> return () -- Store the key in the channel. - STM.atomically $ STM.writeTQueue schanKey K.KM{key, modifier} + STM.atomically $ STM.writeTQueue schanKey K.KM{..} _ -> return () storeKeys sess -- | Output to the screen via the frontend. fdisplay :: FrontendSession -- ^ frontend session data - -> Bool -> Maybe SingleFrame -- ^ the screen frame to draw -> IO () -fdisplay _ _ Nothing = return () -fdisplay FrontendSession{svty} _ (Just rawSF) = +fdisplay _ Nothing = return () +fdisplay FrontendSession{svty} (Just rawSF) = let SingleFrame{sfLevel} = overlayOverlay rawSF img = (foldr (<->) emptyImage . map (foldr (<|>) emptyImage @@ -111,7 +112,7 @@ -- | Display a prompt, wait for any key. fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM fpromptGetKey sess frame = do - fdisplay sess True $ Just frame + fdisplay sess $ Just frame nextKeyEvent sess -- TODO: Ctrl-Home and Ctrl-End are the same as Home and End on some terminals @@ -142,8 +143,11 @@ -- | Translates modifiers to our own encoding. modifierTranslate :: [Modifier] -> K.Modifier -modifierTranslate mods = - if MCtrl `elem` mods then K.Control else K.NoModifier +modifierTranslate mods + | MCtrl `elem` mods = K.Control + | MAlt `elem` mods = K.Alt + | MShift `elem` mods = K.Shift + | otherwise = K.NoModifier -- TODO: with vty 5.0 check if bold is still needed. -- A hack to get bright colors via the bold attribute. Depending on terminal diff --git a/Game/LambdaHack/Client/UI/HandleHumanClient.hs b/Game/LambdaHack/Client/UI/HandleHumanClient.hs --- a/Game/LambdaHack/Client/UI/HandleHumanClient.hs +++ b/Game/LambdaHack/Client/UI/HandleHumanClient.hs @@ -19,14 +19,14 @@ -- invoked in targeting mode on a remote level (level different than -- the level of the leader). cmdHumanSem :: MonadClientUI m => HumanCmd -> m (SlideOrCmd RequestUI) -cmdHumanSem cmd = do +cmdHumanSem cmd = if noRemoteHumanCmd cmd then do -- If in targeting mode, check if the current level is the same -- as player level and refuse performing the action otherwise. arena <- getArenaUI lidV <- viewedLevel - if (arena /= lidV) then - failWith $ "command disabled on a remote level, press ESC to switch back" + if arena /= lidV then + failWith "command disabled on a remote level, press ESC to switch back" else cmdAction cmd else cmdAction cmd @@ -34,16 +34,20 @@ cmdAction :: MonadClientUI m => HumanCmd -> m (SlideOrCmd RequestUI) cmdAction cmd = case cmd of -- Global. - Move v -> fmap anyToUI <$> moveRunHuman False v - Run v -> fmap anyToUI <$> moveRunHuman True v + Move v -> fmap anyToUI <$> moveRunHuman True True False False v + Run v -> fmap anyToUI <$> moveRunHuman True True True True v Wait -> Right <$> fmap ReqUITimed waitHuman MoveItem cLegalRaw toCStore mverb _ auto -> fmap ReqUITimed <$> moveItemHuman cLegalRaw toCStore mverb auto + DescribeItem cstore -> fmap ReqUITimed <$> describeItemHuman cstore Project ts -> fmap ReqUITimed <$> projectHuman ts Apply ts -> fmap ReqUITimed <$> applyHuman ts AlterDir ts -> fmap ReqUITimed <$> alterDirHuman ts TriggerTile ts -> fmap ReqUITimed <$> triggerTileHuman ts - StepToTarget -> fmap anyToUI <$> stepToTargetHuman + RunOnceAhead -> fmap anyToUI <$> runOnceAheadHuman + MoveOnceToCursor -> fmap anyToUI <$> moveOnceToCursorHuman + RunOnceToCursor -> fmap anyToUI <$> runOnceToCursorHuman + ContinueToCursor -> fmap anyToUI <$> continueToCursorHuman GameRestart t -> gameRestartHuman t GameExit -> gameExitHuman @@ -56,11 +60,11 @@ PickLeader k -> Left <$> pickLeaderHuman k MemberCycle -> Left <$> memberCycleHuman MemberBack -> Left <$> memberBackHuman - DescribeItem cstore -> Left <$> describeItemHuman cstore - AllOwned -> Left <$> allOwnedHuman - SelectActor -> Left <$> selectActorHuman + SelectActor -> addNoSlides selectActorHuman SelectNone -> addNoSlides selectNoneHuman Clear -> addNoSlides clearHuman + StopIfTgtMode -> addNoSlides stopIfTgtModeHuman + SelectWithPointer -> addNoSlides selectWithPointer Repeat n -> addNoSlides $ repeatHuman n Record -> Left <$> recordHuman History -> Left <$> historyHuman @@ -74,14 +78,18 @@ MoveCursor v k -> Left <$> moveCursorHuman v k TgtFloor -> Left <$> tgtFloorHuman TgtEnemy -> Left <$> tgtEnemyHuman - TgtUnknown -> Left <$> tgtUnknownHuman - TgtItem -> Left <$> tgtItemHuman - TgtStair up -> Left <$> tgtStairHuman up TgtAscend k -> Left <$> tgtAscendHuman k EpsIncr b -> Left <$> epsIncrHuman b TgtClear -> Left <$> tgtClearHuman + CursorUnknown -> Left <$> cursorUnknownHuman + CursorItem -> Left <$> cursorItemHuman + CursorStair up -> Left <$> cursorStairHuman up Cancel -> Left <$> cancelHuman mainMenuHuman Accept -> Left <$> acceptHuman helpHuman + CursorPointerFloor -> addNoSlides cursorPointerFloorHuman + CursorPointerEnemy -> addNoSlides cursorPointerEnemyHuman + TgtPointerFloor -> Left <$> tgtPointerFloorHuman + TgtPointerEnemy -> Left <$> tgtPointerEnemyHuman addNoSlides :: Monad m => m () -> m (SlideOrCmd RequestUI) addNoSlides cmdCli = cmdCli >> return (Left mempty) diff --git a/Game/LambdaHack/Client/UI/HandleHumanGlobalClient.hs b/Game/LambdaHack/Client/UI/HandleHumanGlobalClient.hs --- a/Game/LambdaHack/Client/UI/HandleHumanGlobalClient.hs +++ b/Game/LambdaHack/Client/UI/HandleHumanGlobalClient.hs @@ -7,9 +7,10 @@ -- TODO: document module Game.LambdaHack.Client.UI.HandleHumanGlobalClient ( -- * Commands that usually take time - moveRunHuman, waitHuman, moveItemHuman + moveRunHuman, waitHuman, moveItemHuman, describeItemHuman , projectHuman, applyHuman, alterDirHuman, triggerTileHuman - , stepToTargetHuman + , runOnceAheadHuman, moveOnceToCursorHuman + , runOnceToCursorHuman, continueToCursorHuman -- * Commands that never take time , gameRestartHuman, gameExitHuman, gameSaveHuman, tacticHuman, automateHuman ) where @@ -22,7 +23,6 @@ import Data.List import Data.Maybe import Data.Monoid -import qualified Data.Text as T import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Client.BfsClient @@ -64,16 +64,42 @@ -- * Move and Run moveRunHuman :: MonadClientUI m - => Bool -> Vector -> m (SlideOrCmd RequestAnyAbility) -moveRunHuman run dir = do + => Bool -> Bool -> Bool -> Bool -> Vector + -> m (SlideOrCmd RequestAnyAbility) +moveRunHuman initialStep finalGoal run runAhead dir = do tgtMode <- getsClient stgtMode if isJust tgtMode then - fmap Left $ moveCursorHuman dir (if run then 10 else 1) + Left <$> moveCursorHuman dir (if run then 10 else 1) else do arena <- getArenaUI leader <- getLeaderUI sb <- getsState $ getActorBody leader fact <- getsState $ (EM.! bfid sb) . sfactionD + -- Start running in the given direction. The first turn of running + -- succeeds much more often than subsequent turns, because we ignore + -- most of the disturbances, since the player is mostly aware of them + -- and still explicitly requests a run, knowing how it behaves. + sel <- getsClient sselected + let runMembers = if runAhead || noRunWithMulti fact + then [leader] -- TODO: warn? + else ES.toList (ES.delete leader sel) ++ [leader] + runParams = RunParams { runLeader = leader + , runMembers + , runInitial = True + , runStopMsg = Nothing + , runWaiting = 0 } + macroRun25 = ["CTRL-comma", "CTRL-V"] + when (initialStep && run) $ do + modifyClient $ \cli -> + cli {srunning = Just runParams} + when runAhead $ + modifyClient $ \cli -> + cli {slastPlay = map K.mkKM macroRun25 ++ slastPlay cli} + -- When running, the invisible actor is hit (not displaced!), + -- so that running in the presence of roving invisible + -- actors is equivalent to moving (with visible actors + -- this is not a problem, since runnning stops early enough). + -- TODO: stop running at invisible actor let tpos = bpos sb `shift` dir -- We start by checking actors at the the target position, -- which gives a partial information (actors can be invisible), @@ -82,39 +108,22 @@ tgts <- getsState $ posToActors tpos arena case tgts of [] -> do -- move or search or alter - -- Start running in the given direction. The first turn of running - -- succeeds much more often than subsequent turns, because we ignore - -- most of the disturbances, since the player is mostly aware of them - -- and still explicitly requests a run, knowing how it behaves. - runStopOrCmd <- moveRunAid leader dir + runStopOrCmd <- moveSearchAlterAid leader dir case runStopOrCmd of Left stopMsg -> failWith stopMsg - Right runCmd@(RequestAnyAbility ReqMove{}) -> do - sel <- getsClient sselected - let runMembers = if noRunWithMulti fact - then [leader] -- TODO: warn? - else ES.toList (ES.delete leader sel) ++ [leader] - runParams = RunParams { runLeader = leader - , runMembers - , runDist = 0 - , runStopMsg = Nothing - , runInitDir = Just dir } - when run $ modifyClient $ \cli -> cli {srunning = Just runParams} + Right runCmd -> + -- Don't check @initialStep@ and @finalGoal@ + -- and don't stop going to target: door opening is mundane enough. return $ Right runCmd - -- Any other command does ends the run immediately. - Right runCmd -> return $ Right runCmd - -- When running, the invisible actor is hit (not displaced!), - -- so that running in the presence of roving invisible - -- actors is equivalent to moving (with visible actors - -- this is not a problem, since runnning stops early enough). - -- TODO: stop running at invisible actor - [((target, _), _)] | run -> + [((target, _), _)] | run && initialStep -> + -- No @stopPlayBack@: initial displace is benign enough. -- Displacing requires accessibility, but it's checked later on. fmap RequestAnyAbility <$> displaceAid target - _ : _ : _ | run -> do - assert (all (bproj . snd . fst) tgts) skip + _ : _ : _ | run && initialStep -> do + let !_A = assert (all (bproj . snd . fst) tgts) () failSer DisplaceProjectiles - ((target, tb), _) : _ -> do + ((target, tb), _) : _ | initialStep && finalGoal -> do + stopPlayBack -- don't ever auto-repeat melee -- No problem if there are many projectiles at the spot. We just -- attack the first one. -- We always see actors from our own faction. @@ -124,16 +133,17 @@ else do -- Select adjacent actor by bumping into him. Takes no time. success <- pickLeader True target - assert (success `blame` "bump self" - `twith` (leader, target, tb)) skip + let !_A = assert (success `blame` "bump self" + `twith` (leader, target, tb)) () return $ Left mempty else -- Attacking does not require full access, adjacency is enough. fmap RequestAnyAbility <$> meleeAid target + _ : _ -> failWith "actor in the way" -- | Actor atttacks an enemy actor or his own projectile. meleeAid :: MonadClientUI m - => ActorId -> m (SlideOrCmd (RequestTimed AbMelee)) + => ActorId -> m (SlideOrCmd (RequestTimed 'AbMelee)) meleeAid target = do leader <- getLeaderUI sb <- getsState $ getActorBody leader @@ -141,18 +151,18 @@ sfact <- getsState $ (EM.! bfid sb) . sfactionD mel <- pickWeaponClient leader target case mel of - [] -> failWith "nothing to melee with" - wp : _ -> do + Nothing -> failWith "nothing to melee with" + Just wp -> do let returnCmd = return $ Right wp res | bproj tb || isAtWar sfact (bfid tb) = returnCmd | isAllied sfact (bfid tb) = do go1 <- displayYesNo ColorBW "You are bound by an alliance. Really attack?" - if not go1 then failWith "Attack canceled." else returnCmd + if not go1 then failWith "attack canceled" else returnCmd | otherwise = do go2 <- displayYesNo ColorBW "This attack will start a war. Are you sure?" - if not go2 then failWith "Attack canceled." else returnCmd + if not go2 then failWith "attack canceled" else returnCmd res -- Seeing the actor prevents altering a tile under it, but that -- does not limit the player, he just doesn't waste a turn @@ -160,7 +170,7 @@ -- | Actor swaps position with another. displaceAid :: MonadClientUI m - => ActorId -> m (SlideOrCmd (RequestTimed AbDisplace)) + => ActorId -> m (SlideOrCmd (RequestTimed 'AbDisplace)) displaceAid target = do cops <- getsState scops leader <- getLeaderUI @@ -169,9 +179,8 @@ tfact <- getsState $ (EM.! bfid tb) . sfactionD activeItems <- activeItemsClient target disp <- getsState $ dispEnemy leader target activeItems - actorSk <- getsState $ maxActorSkills target activeItems - let immobile = EM.findWithDefault 0 AbDisplace actorSk <= 0 - && EM.findWithDefault 0 AbMove actorSk <= 0 + let actorMaxSk = sumSkills activeItems + immobile = EM.findWithDefault 0 AbMove actorMaxSk <= 0 spos = bpos sb tpos = bpos tb adj = checkAdjacent sb tb @@ -192,15 +201,60 @@ tgts <- getsState $ posToActors tpos lid case tgts of [] -> assert `failure` (leader, sb, target, tb) - [_] -> do - return $ Right $ ReqDisplace target + [_] -> return $ Right $ ReqDisplace target _ -> failSer DisplaceProjectiles else failSer DisplaceAccess +-- | Actor moves or searches or alters. No visible actor at the position. +moveSearchAlterAid :: MonadClient m + => ActorId -> Vector -> m (Either Msg RequestAnyAbility) +moveSearchAlterAid source dir = do + cops@Kind.COps{cotile} <- getsState scops + sb <- getsState $ getActorBody source + let lid = blid sb + lvl <- getLevel lid + let spos = bpos sb -- source position + tpos = spos `shift` dir -- target position + t = lvl `at` tpos + runStopOrCmd + -- Movement requires full access. + | accessible cops lvl spos tpos = + -- A potential invisible actor is hit. War started without asking. + Right $ RequestAnyAbility $ ReqMove dir + -- No access, so search and/or alter the tile. Non-walkability is + -- not implied by the lack of access. + | not (Tile.isWalkable cotile t) + && (not (knownLsecret lvl) + || (isSecretPos lvl tpos -- possible secrets here + && (Tile.isSuspect cotile t -- not yet searched + || Tile.hideAs cotile t /= t)) -- search again + || Tile.isOpenable cotile t + || Tile.isClosable cotile t + || Tile.isChangeable cotile t) + = if EM.member tpos $ lfloor lvl then + Left $ showReqFailure AlterBlockItem + else + Right $ RequestAnyAbility $ ReqAlter tpos Nothing + -- We don't use MoveSer, because we don't hit invisible actors. + -- The potential invisible actor, e.g., in a wall or in + -- an inaccessible doorway, is made known, taking a turn. + -- If server performed an attack for free + -- on the invisible actor anyway, the player (or AI) + -- would be tempted to repeatedly hit random walls + -- in hopes of killing a monster lurking within. + -- If the action had a cost, misclicks would incur the cost, too. + -- Right now the player may repeatedly alter tiles trying to learn + -- about invisible pass-wall actors, but when an actor detected, + -- it costs a turn and does not harm the invisible actors, + -- so it's not so tempting. + -- Ignore a known boring, not accessible tile. + | otherwise = Left "never mind" + return $! runStopOrCmd + -- * Wait -- | Leader waits a turn (and blocks, etc.). -waitHuman :: MonadClientUI m => m (RequestTimed AbWait) +waitHuman :: MonadClientUI m => m (RequestTimed 'AbWait) waitHuman = do modifyClient $ \cli -> cli {swaitTimes = abs (swaitTimes cli) + 1} return ReqWait @@ -208,76 +262,122 @@ -- * MoveItem moveItemHuman :: MonadClientUI m - => [CStore] -> CStore -> (Maybe MU.Part) -> Bool - -> m (SlideOrCmd (RequestTimed AbMoveItem)) + => [CStore] -> CStore -> Maybe MU.Part -> Bool + -> m (SlideOrCmd (RequestTimed 'AbMoveItem)) moveItemHuman cLegalRaw destCStore mverb auto = do - assert (destCStore `notElem` cLegalRaw) skip + let !_A = assert (destCStore `notElem` cLegalRaw) () let verb = fromMaybe (MU.Text $ verbCStore destCStore) mverb leader <- getLeaderUI b <- getsState $ getActorBody leader activeItems <- activeItemsClient leader - let cLegal = if calmEnough b activeItems - then cLegalRaw - else if destCStore == CSha - then [] - else delete CSha cLegalRaw + -- This calmE is outdated when one of the items increases max Calm + -- (e.g., in pickup, which handles many items at once), but this is OK, + -- the server accepts item movement based on calm at the start, not end + -- or in the middle. + -- 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) + let calmE = calmEnough b activeItems + cLegal | calmE = cLegalRaw + | destCStore == CSha = [] + | otherwise = delete CSha cLegalRaw + ret4 :: MonadClientUI m + => CStore -> [(ItemId, ItemFull)] + -> Int -> [(ItemId, Int, CStore, CStore)] + -> m (Either Slideshow [(ItemId, Int, CStore, CStore)]) + ret4 _ [] _ acc = return $ Right $ reverse acc + ret4 fromCStore ((iid, itemFull) : rest) oldN acc = do + let k = itemK itemFull + retRec toCStore = + let n = oldN + if toCStore == CEqp then k else 0 + in ret4 fromCStore rest n ((iid, k, fromCStore, toCStore) : acc) + if cLegalRaw == [CGround] -- normal pickup + then case destCStore of + CEqp | calmE && goesIntoSha itemFull -> + retRec CSha + CEqp | goesIntoInv itemFull -> + retRec CInv + CEqp | eqpOverfull b (oldN + k) -> do + msgAdd $ "Warning:" <+> showReqFailure EqpOverfull <> "." + retRec CInv + _ -> + retRec destCStore + else case destCStore of + CEqp | eqpOverfull b (oldN + k) -> failSer EqpOverfull + _ -> retRec destCStore ggi <- if auto - then getAnyItem verb cLegalRaw cLegal False False - else getAnyItem verb cLegalRaw cLegal True True + then getAnyItems verb cLegalRaw cLegal False False + else getAnyItems verb cLegalRaw cLegal True True case ggi of - Right ((iid, itemFull), CActor _ fromCStore) -> do - let k = itemK itemFull - retReq toCStore = - return $ Right $ ReqMoveItem iid k fromCStore toCStore - if fromCStore == CGround - then case destCStore of - CEqp | goesIntoInv (itemBase itemFull) -> - retReq CInv - CEqp | eqpOverfull b k -> do - msgAdd $ "Warning:" <+> showReqFailure EqpOverfull <> "." - retReq CInv - _ -> - retReq destCStore - else case destCStore of - CEqp | eqpOverfull b k -> failSer EqpOverfull - _ -> retReq destCStore + Right (l, MStore fromCStore) -> do + leader2 <- getLeaderUI + b2 <- getsState $ getActorBody leader2 + activeItems2 <- activeItemsClient leader2 + let calmE2 = calmEnough b2 activeItems2 + -- This is not ideal, because the failure message comes late, + -- but it's simple and good enough. + if not calmE2 && destCStore == CSha then failSer ItemNotCalm + else do + l4 <- ret4 fromCStore l 0 [] + return $! case l4 of + Left sli -> Left sli + Right [] -> assert `failure` ggi + Right lr -> Right $ ReqMoveItems lr Left slides -> return $ Left slides _ -> assert `failure` ggi +-- * DescribeItem + +-- | Display items from a given container store and describe the chosen one. +describeItemHuman :: MonadClientUI m + => ItemDialogMode -> m (SlideOrCmd (RequestTimed 'AbMoveItem)) +describeItemHuman = describeItemC + -- * Project -projectHuman :: MonadClientUI m - => [Trigger] -> m (SlideOrCmd (RequestTimed AbProject)) +projectHuman :: forall m. MonadClientUI m + => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbProject)) projectHuman ts = do leader <- getLeaderUI - tgtPos <- leaderTgtToPos + lidV <- viewedLevel + oldTgtMode <- getsClient stgtMode + -- Show the targeting line, temporarily. + modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode lidV} + -- Set cursor to the personal target, permanently. tgt <- getsClient $ getTarget leader - case tgtPos of - Nothing -> failWith "last target invalid" - Just pos -> do - -- Set cursor to the personal target, temporarily. - oldCursor <- getsClient scursor - modifyClient $ \cli -> cli {scursor = fromMaybe (scursor cli) tgt} - -- Show the targeting line, temporarily. - oldTgtMode <- getsClient stgtMode - lidV <- viewedLevel - modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode lidV} - canAim <- leaderTgtAims - oldEps <- getsClient seps - outcome <- case canAim of - Right newEps -> do - -- Modify @seps@,, temporarily. - modifyClient $ \cli -> cli {seps = newEps} - projectPos ts pos + modifyClient $ \cli -> cli {scursor = fromMaybe (scursor cli) tgt} + -- Let the user pick the item to fling. + let posFromCursor :: m (Either Msg Point) + posFromCursor = do + canAim <- aidTgtAims leader lidV Nothing + case canAim of + Right newEps -> do + -- Modify @seps@, permanently. + modifyClient $ \cli -> cli {seps = newEps} + mpos <- aidTgtToPos leader lidV Nothing + case mpos of + Nothing -> assert `failure` (tgt, leader, lidV) + Just pos -> do + munit <- projectCheck pos + case munit of + Nothing -> return $ Right pos + Just reqFail -> return $ Left $ showReqFailure reqFail + Left cause -> return $ Left cause + mitem <- projectItem ts posFromCursor + outcome <- case mitem of + Right (iid, fromCStore) -> do + mpos <- posFromCursor + case mpos of + Right pos -> do + eps <- getsClient seps + return $ Right $ ReqProject pos eps iid fromCStore Left cause -> failWith cause - modifyClient $ \cli -> cli { stgtMode = oldTgtMode - , scursor = oldCursor - , seps = oldEps } - return outcome + Left sli -> return $ Left sli + modifyClient $ \cli -> cli {stgtMode = oldTgtMode} + return outcome -projectPos :: MonadClientUI m - => [Trigger] -> Point -> m (SlideOrCmd (RequestTimed AbProject)) -projectPos ts tpos = do +projectCheck :: MonadClientUI m => Point -> m (Maybe ReqFailure) +projectCheck tpos = do Kind.COps{cotile} <- getsState scops leader <- getLeaderUI eps <- getsClient seps @@ -286,48 +386,70 @@ spos = bpos sb Level{lxsize, lysize} <- getLevel lid case bla lxsize lysize eps spos tpos of - Nothing -> failSer ProjectAimOnself + Nothing -> return $ Just ProjectAimOnself Just [] -> assert `failure` "project from the edge of level" - `twith` (spos, tpos, sb, ts) + `twith` (spos, tpos, sb) Just (pos : _) -> do lvl <- getLevel lid let t = lvl `at` pos if not $ Tile.isWalkable cotile t - then failSer ProjectBlockTerrain + then return $ Just ProjectBlockTerrain else do mab <- getsState $ posToActor pos lid if maybe True (bproj . snd . fst) mab - then projectEps ts tpos eps - else failSer ProjectBlockActor + then return Nothing + else return $ Just ProjectBlockActor -projectEps :: MonadClientUI m - => [Trigger] -> Point -> Int - -> m (SlideOrCmd (RequestTimed AbProject)) -projectEps ts tpos eps = do +projectItem :: forall m. MonadClientUI m + => [Trigger] -> m (Either Msg Point) + -> m (SlideOrCmd (ItemId, CStore)) +projectItem ts posFromCursor = do leader <- getLeaderUI b <- getsState $ getActorBody leader + activeItems <- activeItemsClient leader actorSk <- actorSkillsClient leader let skill = EM.findWithDefault 0 AbProject actorSk - activeItems <- activeItemsClient leader - let cLegal = [CGround, CInv, CEqp] + cLegal = [CGround, CInv, CEqp, CSha] (verb1, object1) = case ts of [] -> ("aim", "item") tr : _ -> (verb tr, object tr) triggerSyms = triggerSymbols ts - p itemFull@ItemFull{itemBase} = - let legal = permittedProject triggerSyms False skill itemFull b activeItems - in case legal of - Left{} -> legal - Right False -> legal - Right True -> Right $ totalRange itemBase >= chessDist (bpos b) tpos + psuitReq :: m (Either Msg (ItemFull -> Either ReqFailure Bool)) + psuitReq = do + mpos <- posFromCursor + case mpos of + Left err -> return $ Left err + Right pos -> return $ Right $ \itemFull@ItemFull{itemBase} -> do + let legal = permittedProject triggerSyms False skill + itemFull b activeItems + case legal of + Left{} -> legal + Right False -> legal + Right True -> + Right $ totalRange itemBase >= chessDist (bpos b) pos + psuit :: m Suitability + psuit = do + mpsuitReq <- psuitReq + case mpsuitReq of + -- If target invalid, no item is considered a (suitable) missile. + Left err -> return $ SuitsNothing err + Right psuitReqFun -> return $ SuitsSomething $ \itemFull -> + case psuitReqFun itemFull of + Left _ -> False + Right suit -> suit prompt = makePhrase ["What", object1, "to", verb1] - promptGeneric = "What item to fling" - ggi <- getGroupItem (either (const False) id . p) prompt promptGeneric cLegal cLegal + promptGeneric = "What to fling" + ggi <- getGroupItem psuit prompt promptGeneric True + cLegal cLegal case ggi of - Right ((iid, itemFull), CActor _ fromCStore) -> - case p itemFull of - Left reqFail -> failSer reqFail - Right _ -> return $ Right $ ReqProject tpos eps iid fromCStore + Right ((iid, itemFull), MStore fromCStore) -> do + mpsuitReq <- psuitReq + case mpsuitReq of + Left err -> failWith err + Right psuitReqFun -> + case psuitReqFun itemFull of + Left reqFail -> failSer reqFail + Right _ -> return $ Right (iid, fromCStore) Left slides -> return $ Left slides _ -> assert `failure` ggi @@ -339,24 +461,27 @@ -- * Apply applyHuman :: MonadClientUI m - => [Trigger] -> m (SlideOrCmd (RequestTimed AbApply)) + => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbApply)) applyHuman ts = do leader <- getLeaderUI b <- getsState $ getActorBody leader actorSk <- actorSkillsClient leader let skill = EM.findWithDefault 0 AbProject actorSk activeItems <- activeItemsClient leader - let cLegal = [CGround, CInv, CEqp] + localTime <- getsState $ getLocalTime (blid b) + let cLegal = [CGround, CInv, CEqp, CSha] (verb1, object1) = case ts of - [] -> ("activate", "item") + [] -> ("apply", "item") tr : _ -> (verb tr, object tr) triggerSyms = triggerSymbols ts - p itemFull = permittedApply triggerSyms skill itemFull b activeItems + p itemFull = + permittedApply triggerSyms localTime skill itemFull b activeItems prompt = makePhrase ["What", object1, "to", verb1] - promptGeneric = "What item to activate" - ggi <- getGroupItem (either (const False) id . p) prompt promptGeneric cLegal cLegal + promptGeneric = "What to apply" + ggi <- getGroupItem (return $ SuitsSomething $ either (const False) id . p) + prompt promptGeneric False cLegal cLegal case ggi of - Right ((iid, itemFull), CActor _ fromCStore) -> + Right ((iid, itemFull), MStore fromCStore) -> case p itemFull of Left reqFail -> failSer reqFail Right _ -> return $ Right $ ReqApply iid fromCStore @@ -365,37 +490,43 @@ -- * AlterDir +-- TODO: accept mouse, too -- | Ask for a direction and alter a tile, if possible. alterDirHuman :: MonadClientUI m - => [Trigger] -> m (SlideOrCmd (RequestTimed AbAlter)) + => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbAlter)) alterDirHuman ts = do Config{configVi, configLaptop} <- askConfig let verb1 = case ts of [] -> "alter" tr : _ -> verb tr - keys = zipWith K.KM (repeat K.NoModifier) - (K.dirAllKey configVi configLaptop) + keys = map (K.toKM K.NoModifier) (K.dirAllKey configVi configLaptop) prompt = makePhrase ["What to", verb1 <> "? [movement key"] me <- displayChoiceUI prompt emptyOverlay keys case me of Left slides -> failSlides slides - Right e -> K.handleDir configVi configLaptop e (flip alterTile ts) + Right e -> K.handleDir configVi configLaptop e (`alterTile` ts) (failWith "never mind") -- | Player tries to alter a tile using a feature. alterTile :: MonadClientUI m - => Vector -> [Trigger] -> m (SlideOrCmd (RequestTimed AbAlter)) + => Vector -> [Trigger] -> m (SlideOrCmd (RequestTimed 'AbAlter)) alterTile dir ts = do cops@Kind.COps{cotile} <- getsState scops leader <- getLeaderUI b <- getsState $ getActorBody leader lvl <- getLevel $ blid b + as <- getsState $ actorList (const True) (blid b) let tpos = bpos b `shift` dir t = lvl `at` tpos alterFeats = alterFeatures ts case filter (\feat -> Tile.hasFeature cotile feat t) alterFeats of [] -> failWith $ guessAlter cops alterFeats t - feat : _ -> return $ Right $ ReqAlter tpos $ Just feat + feat : _ -> + if EM.notMember tpos $ lfloor lvl then + if unoccupied as tpos then + return $ Right $ ReqAlter tpos $ Just feat + else failSer AlterBlockActor + else failSer AlterBlockItem alterFeatures :: [Trigger] -> [TK.Feature] alterFeatures [] = [] @@ -416,7 +547,7 @@ -- | Leader tries to trigger the tile he's standing on. triggerTileHuman :: MonadClientUI m - => [Trigger] -> m (SlideOrCmd (RequestTimed AbTrigger)) + => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbTrigger)) triggerTileHuman ts = do tgtMode <- getsClient stgtMode if isJust tgtMode then do @@ -427,12 +558,12 @@ mk = getK ts case mk of Nothing -> failWith "never mind" - Just k -> fmap Left $ tgtAscendHuman k + Just k -> Left <$> tgtAscendHuman k else triggerTile ts -- | Player tries to trigger a tile using a feature. triggerTile :: MonadClientUI m - => [Trigger] -> m (SlideOrCmd (RequestTimed AbTrigger)) + => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbTrigger)) triggerTile ts = do cops@Kind.COps{cotile} <- getsState scops leader <- getLeaderUI @@ -465,18 +596,18 @@ "This is the way out, but where would you go in this alien world?" else do go <- displayYesNo ColorFull "This is the way out. Really leave now?" - if not go then failWith "Game resumed." + if not go then failWith "game resumed" else do (_, total) <- getsState $ calculateTotal b if total == 0 then do -- The player can back off at each of these steps. go1 <- displayMore ColorBW "Afraid of the challenge? Leaving so soon and empty-handed?" - if not go1 then failWith "Brave soul!" + if not go1 then failWith "brave soul!" else do go2 <- displayMore ColorBW "Next time try to grab some loot before escape!" - if not go2 then failWith "Here's your chance!" + if not go2 then failWith "here's your chance!" else return $ Right () else return $ Right () _ -> return $ Right () @@ -494,33 +625,139 @@ else assert `failure` fs guessTrigger _ _ _ = "never mind" --- * StepToTarget +-- * RunOnceAhead -stepToTargetHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility) -stepToTargetHuman = do +runOnceAheadHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility) +runOnceAheadHuman = do + side <- getsClient sside + fact <- getsState $ (EM.! side) . sfactionD + leader <- getLeaderUI + srunning <- getsClient srunning + -- When running, stop if disturbed. If not running, stop at once. + case srunning of + Nothing -> do + stopPlayBack + return $ Left mempty + Just RunParams{runMembers} + | noRunWithMulti fact && runMembers /= [leader] -> do + stopPlayBack + Config{configRunStopMsgs} <- askConfig + if configRunStopMsgs + then failWith "run stop: automatic leader change" + else return $ Left mempty + Just runParams -> do + arena <- getArenaUI + runOutcome <- continueRun arena runParams + case runOutcome of + Left stopMsg -> do + stopPlayBack + Config{configRunStopMsgs} <- askConfig + if configRunStopMsgs + then failWith $ "run stop:" <+> stopMsg + else return $ Left mempty + Right runCmd -> + return $ Right runCmd + +-- * MoveOnceToCursor + +moveOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility) +moveOnceToCursorHuman = goToCursor True False + +goToCursor :: MonadClientUI m + => Bool -> Bool -> m (SlideOrCmd RequestAnyAbility) +goToCursor initialStep run = do tgtMode <- getsClient stgtMode -- Movement is legal only outside targeting mode. - -- TODO: use this command for something in targeting mode. - if isJust tgtMode then failWith "cannot move in targeting mode" + if isJust tgtMode then failWith "cannot move in aiming mode" else do leader <- getLeaderUI b <- getsState $ getActorBody leader - tgtPos <- leaderTgtToPos - case tgtPos of - Nothing -> failWith "target not set" - Just c | c == bpos b -> failWith "target reached" + cursorPos <- cursorToPos + case cursorPos of + Nothing -> failWith "no leader" + Just c | c == bpos b -> + if initialStep + then return $ Right $ RequestAnyAbility ReqWait + else do + report <- getsClient sreport + if nullReport report + then return $ Left mempty + -- Mark that the messages are accumulated, not just from last move. + else failWith "crosshair now reached" Just c -> do - (_, mpath) <- getCacheBfsAndPath leader c + running <- getsClient srunning + case running of + -- Don't use running params from previous run or goto-cursor. + Just paramOld | not initialStep -> do + arena <- getArenaUI + runOutcome <- multiActorGoTo arena c paramOld + case runOutcome of + Left stopMsg -> failWith stopMsg + Right (finalGoal, dir) -> + moveRunHuman initialStep finalGoal run False dir + _ -> do + let !_A = assert (initialStep || not run) () + (_, mpath) <- getCacheBfsAndPath leader c + case mpath of + Nothing -> failWith "no route to crosshair" + Just [] -> assert `failure` (leader, b, c) + Just (p1 : _) -> do + let finalGoal = p1 == c + dir = towards (bpos b) p1 + moveRunHuman initialStep finalGoal run False dir + +multiActorGoTo :: MonadClient m + => LevelId -> Point -> RunParams + -> m (Either Msg (Bool, Vector)) +multiActorGoTo arena c paramOld = + case paramOld of + RunParams{runMembers = []} -> + return $ Left "selected actors no longer there" + RunParams{runMembers = r : rs, runWaiting} -> do + onLevel <- getsState $ memActor r arena + if not onLevel then do + let paramNew = paramOld {runMembers = rs} + multiActorGoTo arena c paramNew + else do + s <- getState + modifyClient $ updateLeader r s + let runMembersNew = rs ++ [r] + paramNew = paramOld { runMembers = runMembersNew + , runWaiting = 0} + b <- getsState $ getActorBody r + (_, mpath) <- getCacheBfsAndPath r c case mpath of - Nothing -> failWith "no route to target" - Just [] -> assert `failure` (leader, b, bpos b, c) + Nothing -> return $ Left "no route to crosshair" + Just [] -> + -- This actor already at goal; will be caught in goToCursor. + return $ Left "" Just (p1 : _) -> do - as <- getsState $ posToActors p1 (blid b) - if not $ null as then - failWith "actor in the path to target" - else - moveRunHuman False $ towards (bpos b) p1 + let finalGoal = p1 == c + dir = towards (bpos b) p1 + tpos = bpos b `shift` dir + tgts <- getsState $ posToActors tpos arena + case tgts of + [] -> do + modifyClient $ \cli -> cli {srunning = Just paramNew} + return $ Right (finalGoal, dir) + [((target, _), _)] + | target `elem` rs || runWaiting <= length rs -> + -- Let r wait until all others move. Mark it in runWaiting + -- to avoid cycles. When all wait for each other, fail. + multiActorGoTo arena c paramNew{runWaiting=runWaiting + 1} + _ -> + return $ Left "actor in the way" +-- * RunOnceToCursor + +runOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility) +runOnceToCursorHuman = goToCursor True True + +-- * ContinueToCursor + +continueToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility) +continueToCursorHuman = goToCursor False False{-irrelevant-} + -- * GameRestart; does not take time gameRestartHuman :: MonadClientUI m => GroupName ModeKind -> m (SlideOrCmd RequestUI) @@ -541,8 +778,8 @@ b2 <- displayYesNo ColorBW "Current progress will be lost! Really restart the game?" msg2 <- rndToAction $ oneOf - [ "Yea, would be a pity to leave them all to die." - , "Yea, a shame to get your own team stranded." ] + [ "yea, would be a pity to leave them all to die" + , "yea, a shame to get your own team stranded" ] if not b2 then failWith msg2 else restart @@ -555,7 +792,7 @@ leader <- getLeaderUI DebugModeCli{sdifficultyCli} <- getsClient sdebugCli return $ Right $ ReqUIGameExit leader sdifficultyCli - else failWith "Save and exit canceled." + else failWith "save and exit canceled" -- * GameSave; does not take time @@ -582,10 +819,10 @@ let toT = if fromT == maxBound then minBound else succ fromT go <- displayMore ColorFull $ "Switching tactic to" - <+> T.pack (show toT) -- tshow eats up parens + <+> tshow toT <> ". (This clears targets.)" if not go - then failWith "Tactic change canceled." + then failWith "tactic change canceled" else return $ Right $ ReqUITactic toT -- * Automate; does not take time @@ -599,5 +836,5 @@ else do go <- displayMore ColorBW "Ceding control to AI (ESC to regain)." if not go - then failWith "Automation canceled." + then failWith "automation canceled" else return $ Right ReqUIAutomate diff --git a/Game/LambdaHack/Client/UI/HandleHumanLocalClient.hs b/Game/LambdaHack/Client/UI/HandleHumanLocalClient.hs --- a/Game/LambdaHack/Client/UI/HandleHumanLocalClient.hs +++ b/Game/LambdaHack/Client/UI/HandleHumanLocalClient.hs @@ -5,14 +5,17 @@ ( -- * Assorted commands gameDifficultyCycle , pickLeaderHuman, memberCycleHuman, memberBackHuman - , describeItemHuman, allOwnedHuman - , selectActorHuman, selectNoneHuman, clearHuman, repeatHuman, recordHuman + , selectActorHuman, selectNoneHuman, clearHuman + , stopIfTgtModeHuman, selectWithPointer, repeatHuman, recordHuman , historyHuman, markVisionHuman, markSmellHuman, markSuspectHuman , helpHuman, mainMenuHuman, macroHuman -- * Commands specific to targeting , moveCursorHuman, tgtFloorHuman, tgtEnemyHuman - , tgtUnknownHuman, tgtItemHuman, tgtStairHuman, tgtAscendHuman - , epsIncrHuman, tgtClearHuman, cancelHuman, acceptHuman + , tgtAscendHuman, epsIncrHuman, tgtClearHuman + , cursorUnknownHuman, cursorItemHuman, cursorStairHuman + , cancelHuman, acceptHuman + , cursorPointerFloorHuman, cursorPointerEnemyHuman + , tgtPointerFloorHuman, tgtPointerEnemyHuman ) where -- Cabal @@ -47,20 +50,16 @@ import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.ItemDescription +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.MonadStateRead import Game.LambdaHack.Common.Msg -import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time -import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Content.TileKind as TK @@ -81,18 +80,26 @@ side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD arena <- getArenaUI - let (autoDun, autoLvl) = autoDungeonLevel fact - s <- getState - case tryFindHeroK s side k of - Nothing -> failMsg "No such member of the party." - Just (aid, b) -> - if blid b == arena && autoLvl - then failMsg $ showReqFailure NoChangeLvlLeader - else if autoDun - then failMsg $ showReqFailure NoChangeDunLeader - else do - void $ pickLeader True aid - return mempty + mhero <- getsState $ tryFindHeroK side k + allA <- getsState $ EM.assocs . sactorD + let mactor = let factionA = filter (\(_, body) -> + not (bproj body) && bfid body == side) allA + hs = sortBy (comparing keySelected) factionA + in case drop k hs of + [] -> Nothing + aidb : _ -> Just aidb + mchoice = mhero `mplus` mactor + (autoDun, autoLvl) = autoDungeonLevel fact + case mchoice of + Nothing -> failMsg "no such member of the party" + Just (aid, b) + | blid b == arena && autoLvl -> + failMsg $ showReqFailure NoChangeLvlLeader + | autoDun -> + failMsg $ showReqFailure NoChangeDunLeader + | otherwise -> do + void $ pickLeader True aid + return mempty -- * MemberCycle @@ -106,55 +113,17 @@ memberBackHuman :: MonadClientUI m => m Slideshow memberBackHuman = memberBack True --- * DescribeItem - --- | Display items from a given container store and describe the chosen one. -describeItemHuman :: MonadClientUI m => CStore -> m Slideshow -describeItemHuman cstore = do - leader <- getLeaderUI - describeItemC (CActor leader cstore) False - -describeItemC :: MonadClientUI m => Container -> Bool -> m Slideshow -describeItemC c noEnter = do - let subject body = partActor body - verbSha body activeItems = if calmEnough body activeItems - then "notice" - else "paw distractedly" - prompt body activeItems c2 = case c2 of - CActor _ CSha -> - makePhrase - [MU.Capitalize - $ MU.SubjectVerbSg (subject body) (verbSha body activeItems)] - CTrunk{} -> - makePhrase - [MU.Capitalize $ MU.SubjectVerbSg (subject body) "recall"] - _ -> - makePhrase - [MU.Capitalize $ MU.SubjectVerbSg (subject body) "see"] - ggi <- getStoreItem prompt c noEnter - case ggi of - Right ((_, itemFull), c2) -> do - lid2 <- getsState $ lidFromC c2 - localTime <- getsState $ getLocalTime lid2 - overlayToSlideshow "" $ itemDesc c2 lid2 localTime itemFull - Left slides -> return slides - --- * AllOwned - --- | Display the sum of equipments and inventory of the whole party. -allOwnedHuman :: MonadClientUI m => m Slideshow -allOwnedHuman = do - leader <- getLeaderUI - b <- getsState $ getActorBody leader - describeItemC (CTrunk (bfid b) (blid b) (bpos b)) False - -- * SelectActor -- TODO: make the message (and for selectNoneHuman, pickLeader, etc.) -- optional, since they have a clear representation in the UI elsewhere. -selectActorHuman :: MonadClientUI m => m Slideshow +selectActorHuman :: MonadClientUI m => m () selectActorHuman = do leader <- getLeaderUI + selectAidHuman leader + +selectAidHuman :: MonadClientUI m => ActorId -> m () +selectAidHuman leader = do body <- getsState $ getActorBody leader wasMemeber <- getsClient $ ES.member leader . sselected let upd = if wasMemeber @@ -165,7 +134,6 @@ msgAdd $ makeSentence [subject, if wasMemeber then "deselected" else "selected"] - return mempty -- * SelectNone @@ -192,6 +160,33 @@ clearHuman :: Monad m => m () clearHuman = return () +-- * StopIfTgtMode + +stopIfTgtModeHuman :: MonadClientUI m => m () +stopIfTgtModeHuman = do + tgtMode <- getsClient stgtMode + when (isJust tgtMode) stopPlayBack + +-- * SelectWithPointer + +selectWithPointer:: MonadClientUI m => m () +selectWithPointer = do + km <- getsClient slastKM + let Point{..} = K.pointer km + lidV <- viewedLevel + Level{lysize} <- getLevel lidV + side <- getsClient sside + ours <- getsState $ filter (not . bproj . snd) + . actorAssocs (== side) lidV + -- Select even if no space in status line for the actor's symbol. + let viewed = sortBy (comparing keySelected) ours + when (py == lysize + 1 && px <= length viewed && px >= 0) $ do + if px == 0 then + selectNoneHuman + else + selectAidHuman $ fst $ viewed !! (px - 1) + stopPlayBack + -- * Repeat -- Note that walk followed by repeat should not be equivalent to run, @@ -241,7 +236,7 @@ , "(this level:" , MU.Text (tshow turnsLocal) <> ")" ] <+> "Past messages:" - overlayToBlankSlideshow msg $ renderHistory history + overlayToBlankSlideshow False msg $ renderHistory history -- * MarkVision, MarkSmell, MarkSuspect @@ -259,6 +254,8 @@ markSuspectHuman :: MonadClientUI m => m () markSuspectHuman = do + -- @condBFS@ depends on the setting we change here. + modifyClient $ \cli -> cli {sbfsD = EM.empty} modifyClient toggleMarkSuspect cur <- getsClient smarkSuspect msgAdd $ "Suspect terrain display toggled" <+> if cur then "on." else "off." @@ -331,7 +328,7 @@ overwrite $ pasteVersion $ map T.unpack $ stripFrame mainMenuArt case menuOverlay of [] -> assert `failure` "empty Main Menu overlay" `twith` mainMenuArt - hd : tl -> overlayToBlankSlideshow hd (toOverlay tl) + hd : tl -> overlayToBlankSlideshow True hd (toOverlay tl) -- TODO: keys don't work if tl/=[] -- * Macro @@ -342,199 +339,15 @@ -- * MoveCursor --- | Move the cursor. Assumes targeting mode. -moveCursorHuman :: MonadClientUI m => Vector -> Int -> m Slideshow -moveCursorHuman dir n = do - leader <- getLeaderUI - stgtMode <- getsClient stgtMode - let lidV = maybe (assert `failure` leader) tgtLevelId stgtMode - Level{lxsize, lysize} <- getLevel lidV - lpos <- getsState $ bpos . getActorBody leader - scursor <- getsClient scursor - cursorPos <- cursorToPos - let cpos = fromMaybe lpos cursorPos - shiftB pos = shiftBounded lxsize lysize pos dir - newPos = iterate shiftB cpos !! n - if newPos == cpos then failMsg "never mind" - else do - let tgt = case scursor of - TVector{} -> TVector $ newPos `vectorToFrom` lpos - _ -> TPoint lidV newPos - modifyClient $ \cli -> cli {scursor = tgt} - doLook - --- | Perform look around in the current position of the cursor. --- Normally expects targeting mode and so that a leader is picked. -doLook :: MonadClientUI m => m Slideshow -doLook = do - Kind.COps{cotile=Kind.Ops{ouniqGroup}} <- getsState scops - let unknownId = ouniqGroup "unknown space" - stgtMode <- getsClient stgtMode - case stgtMode of - Nothing -> return mempty - Just tgtMode -> do - leader <- getLeaderUI - let lidV = tgtLevelId tgtMode - lvl <- getLevel lidV - cursorPos <- cursorToPos - per <- getPerFid lidV - b <- getsState $ getActorBody leader - let p = fromMaybe (bpos b) cursorPos - canSee = ES.member p (totalVisible per) - inhabitants <- if canSee - then getsState $ posToActors p lidV - else return [] - seps <- getsClient seps - mnewEps <- makeLine b p seps - itemToF <- itemToFullClient - let aims = isJust mnewEps - enemyMsg = case inhabitants of - [] -> "" - ((_, body), _) : rest -> - -- Even if it's the leader, give his proper name, not 'you'. - let subjects = map (partActor . snd . fst) inhabitants - subject = MU.WWandW subjects - verb = "be here" - desc = if not (null rest) -- many actors - then "" - else case itemDisco $ itemToF (btrunk body) (1, []) of - Nothing -> "" - Just ItemDisco{itemKind} -> IK.idesc itemKind - pdesc = if desc == "" then "" else "(" <> desc <> ")" - in makeSentence [MU.SubjectVerbSg subject verb] <+> pdesc - vis | lvl `at` p == unknownId = "that is" - | not canSee = "you remember" - | not aims = "you are aware of" - | otherwise = "you see" - -- Show general info about current position. - lookMsg <- lookAt True vis canSee p leader enemyMsg - -- Check if there's something lying around at current position. - is <- getsState $ getCBag $ CFloor lidV p - if EM.size is <= 2 then - promptToSlideshow lookMsg - else do - msgAdd lookMsg -- TODO: do not add to history - floorItemOverlay lidV p - --- | Create a list of item names. -floorItemOverlay :: MonadClientUI m => LevelId -> Point -> m Slideshow -floorItemOverlay lid p = describeItemC (CFloor lid p) True +-- in InventoryClient -- * TgtFloor --- | Cycle targeting mode. Do not change position of the cursor, --- switch among things at that position. -tgtFloorHuman :: MonadClientUI m => m Slideshow -tgtFloorHuman = do - lidV <- viewedLevel - leader <- getLeaderUI - lpos <- getsState $ bpos . getActorBody leader - cursorPos <- cursorToPos - scursor <- getsClient scursor - stgtMode <- getsClient stgtMode - bsAll <- getsState $ actorAssocs (const True) lidV - let cursor = fromMaybe lpos cursorPos - tgt = case scursor of - _ | isNothing stgtMode -> -- first key press: keep target - scursor - TEnemy a True -> TEnemy a False - TEnemy{} -> TPoint lidV cursor - TEnemyPos{} -> TPoint lidV cursor - TPoint{} -> TVector $ cursor `vectorToFrom` lpos - TVector{} -> - -- For projectiles, we pick here the first that would be picked - -- by '*', so that all other projectiles on the tile come next, - -- without any intervening actors from other tiles. - case find (\(_, m) -> Just (bpos m) == cursorPos) bsAll of - Just (im, _) -> TEnemy im True - Nothing -> TPoint lidV cursor - modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV} - doLook +-- in InventoryClient -- * TgtEnemy -tgtEnemyHuman :: MonadClientUI m => m Slideshow -tgtEnemyHuman = do - lidV <- viewedLevel - leader <- getLeaderUI - lpos <- getsState $ bpos . getActorBody leader - cursorPos <- cursorToPos - scursor <- getsClient scursor - stgtMode <- getsClient stgtMode - side <- getsClient sside - fact <- getsState $ (EM.! side) . sfactionD - bsAll <- getsState $ actorAssocs (const True) lidV - let ordPos (_, b) = (chessDist lpos $ bpos b, bpos b) - dbs = sortBy (comparing ordPos) bsAll - pickUnderCursor = -- switch to the enemy under cursor, if any - let i = fromMaybe (-1) - $ findIndex ((== cursorPos) . Just . bpos . snd) dbs - in splitAt i dbs - (permitAnyActor, (lt, gt)) = case scursor of - TEnemy a permit | isJust stgtMode -> -- pick next enemy - let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs - in (permit, splitAt (i + 1) dbs) - TEnemy a permit -> -- first key press, retarget old enemy - let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs - in (permit, splitAt i dbs) - TEnemyPos _ _ _ permit -> (permit, pickUnderCursor) - _ -> (False, pickUnderCursor) -- the sensible default is only-foes - gtlt = gt ++ lt - isEnemy b = isAtWar fact (bfid b) - && not (bproj b) - lf = filter (isEnemy . snd) gtlt - tgt | permitAnyActor = case gtlt of - (a, _) : _ -> TEnemy a True - [] -> scursor -- no actors in sight, stick to last target - | otherwise = case lf of - (a, _) : _ -> TEnemy a False - [] -> scursor -- no seen foes in sight, stick to last target - -- Register the chosen enemy, to pick another on next invocation. - modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV} - doLook - --- * TgtUnknown - -tgtUnknownHuman :: MonadClientUI m => m Slideshow -tgtUnknownHuman = do - leader <- getLeaderUI - b <- getsState $ getActorBody leader - mpos <- closestUnknown leader - case mpos of - Nothing -> failMsg "no more unknown spots left" - Just p -> do - let tgt = TPoint (blid b) p - modifyClient $ \cli -> cli {scursor = tgt} - doLook - --- * TgtItem - -tgtItemHuman :: MonadClientUI m => m Slideshow -tgtItemHuman = do - leader <- getLeaderUI - b <- getsState $ getActorBody leader - items <- closestItems leader - case items of - [] -> failMsg "no more items remembered or visible" - (_, (p, _)) : _ -> do - let tgt = TPoint (blid b) p - modifyClient $ \cli -> cli {scursor = tgt} - doLook - --- * TgtStair - -tgtStairHuman :: MonadClientUI m => Bool -> m Slideshow -tgtStairHuman up = do - leader <- getLeaderUI - b <- getsState $ getActorBody leader - stairs <- closestTriggers (Just up) False leader - case stairs of - [] -> failMsg $ "no stairs" - <+> if up then "up" else "down" - p : _ -> do - let tgt = TPoint (blid b) p - modifyClient $ \cli -> cli {scursor = tgt} - doLook +-- in InventoryClient -- * TgtAscend @@ -558,7 +371,7 @@ case rightStairs of Just cpos -> do -- stairs, in the right direction (nln, npos) <- getsState $ whereTo lidV cpos k . sdungeon - assert (nln /= lidV `blame` "stairs looped" `twith` nln) skip + let !_A = assert (nln /= lidV `blame` "stairs looped" `twith` nln) () nlvl <- getLevel nln -- Do not freely reveal the other end of the stairs. let ascDesc (TK.Cause (IK.Ascend _)) = True @@ -568,47 +381,64 @@ then TPoint nln npos -- already known as an exit, focus on it else scursorOld -- unknown, do not reveal modifyClient $ \cli -> cli {scursor, stgtMode = Just (TgtMode nln)} - doLook + doLook False Nothing -> -- no stairs in the right direction case ascendInBranch dungeon k lidV of [] -> failMsg "no more levels in this direction" nln : _ -> do modifyClient $ \cli -> cli {stgtMode = Just (TgtMode nln)} - doLook + doLook False -- * EpsIncr --- | Tweak the @eps@ parameter of the targeting digital line. -epsIncrHuman :: MonadClientUI m => Bool -> m Slideshow -epsIncrHuman b = do - stgtMode <- getsClient stgtMode - if isJust stgtMode - then do - modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else -1} - return mempty - else failMsg "never mind" -- no visual feedback, so no sense +-- in InventoryClient -- * TgtClear -tgtClearHuman :: MonadClientUI m => m Slideshow -tgtClearHuman = do +-- in InventoryClient + +-- * CursorUnknown + +cursorUnknownHuman :: MonadClientUI m => m Slideshow +cursorUnknownHuman = do leader <- getLeaderUI - tgt <- getsClient $ getTarget leader - case tgt of - Just _ -> do - modifyClient $ updateTarget leader (const Nothing) - return mempty - Nothing -> do - scursorOld <- getsClient scursor - b <- getsState $ getActorBody leader - let scursor = case scursorOld of - TEnemy _ permit -> TEnemy leader permit - TEnemyPos _ _ _ permit -> TEnemy leader permit - TPoint{} -> TPoint (blid b) (bpos b) - TVector{} -> TVector (Vector 0 0) - modifyClient $ \cli -> cli {scursor} - doLook + b <- getsState $ getActorBody leader + mpos <- closestUnknown leader + case mpos of + Nothing -> failMsg "no more unknown spots left" + Just p -> do + let tgt = TPoint (blid b) p + modifyClient $ \cli -> cli {scursor = tgt} + doLook False +-- * CursorItem + +cursorItemHuman :: MonadClientUI m => m Slideshow +cursorItemHuman = do + leader <- getLeaderUI + b <- getsState $ getActorBody leader + items <- closestItems leader + case items of + [] -> failMsg "no more items remembered or visible" + (_, (p, _)) : _ -> do + let tgt = TPoint (blid b) p + modifyClient $ \cli -> cli {scursor = tgt} + doLook False + +-- * CursorStair + +cursorStairHuman :: MonadClientUI m => Bool -> m Slideshow +cursorStairHuman up = do + leader <- getLeaderUI + b <- getsState $ getActorBody leader + stairs <- closestTriggers (Just up) leader + case reverse $ sort $ runFrequency stairs of + [] -> failMsg $ "no stairs" <+> if up then "up" else "down" + (_, p) : _ -> do + let tgt = TPoint (blid b) p + modifyClient $ \cli -> cli {scursor = tgt} + doLook False + -- * Cancel -- | Cancel something, e.g., targeting mode, resetting the cursor @@ -624,7 +454,7 @@ targetReject :: MonadClientUI m => m Slideshow targetReject = do modifyClient $ \cli -> cli {stgtMode = Nothing} - failMsg "targeting canceled" + failMsg "target not set" -- * Accept @@ -659,3 +489,29 @@ (targetMsg, _) <- targetDescLeader leader subject <- partAidLeader leader msgAdd $ makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg] + +-- * CursorPointerFloor + +cursorPointerFloorHuman :: MonadClientUI m => m () +cursorPointerFloorHuman = do + look <- cursorPointerFloor False False + let !_A = assert (look == mempty `blame` look) () + modifyClient $ \cli -> cli {stgtMode = Nothing} + +-- * CursorPointerEnemy + +cursorPointerEnemyHuman :: MonadClientUI m => m () +cursorPointerEnemyHuman = do + look <- cursorPointerEnemy False False + let !_A = assert (look == mempty `blame` look) () + modifyClient $ \cli -> cli {stgtMode = Nothing} + +-- * TgtPointerFloor + +tgtPointerFloorHuman :: MonadClientUI m => m Slideshow +tgtPointerFloorHuman = cursorPointerFloor True False + +-- * TgtPointerEnemy + +tgtPointerEnemyHuman :: MonadClientUI m => m Slideshow +tgtPointerEnemyHuman = cursorPointerEnemy True False 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,12 +1,15 @@ +{-# LANGUAGE DeriveGeneric #-} -- | Abstract syntax human player commands. module Game.LambdaHack.Client.UI.HumanCmd ( CmdCategory(..), HumanCmd(..), Trigger(..) , noRemoteHumanCmd, categoryDescription, cmdDescription ) where +import Control.DeepSeq import Control.Exception.Assert.Sugar import Data.Maybe import Data.Text (Text) +import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Common.Actor (verbCStore) @@ -17,19 +20,23 @@ import qualified Game.LambdaHack.Content.TileKind as TK data CmdCategory = - CmdMenu | CmdMove | CmdItem | CmdTgt | CmdAuto | CmdMeta - | CmdDebug | CmdMinimal - deriving (Show, Read, Eq) + CmdMenu | CmdMove | CmdItem | CmdTgt | CmdAuto | CmdMeta | CmdMouse + | CmdInternal | CmdDebug | CmdMinimal + deriving (Show, Read, Eq, Generic) +instance NFData CmdCategory + categoryDescription :: CmdCategory -> Text categoryDescription CmdMenu = "Main Menu" categoryDescription CmdMove = "Terrain exploration and alteration" categoryDescription CmdItem = "Item use" -categoryDescription CmdTgt = "Targeting" +categoryDescription CmdTgt = "Aiming and targeting" categoryDescription CmdAuto = "Automation" categoryDescription CmdMeta = "Assorted" +categoryDescription CmdMouse = "Mouse" +categoryDescription CmdInternal = "Internal" categoryDescription CmdDebug = "Debug" -categoryDescription CmdMinimal = "Minimal cheat sheet for casual play" +categoryDescription CmdMinimal = "The minimal command set" -- | Abstract syntax of player commands. data HumanCmd = @@ -39,11 +46,15 @@ | Run !Vector | Wait | MoveItem ![CStore] !CStore !(Maybe MU.Part) !MU.Part !Bool + | DescribeItem !ItemDialogMode | Project ![Trigger] | Apply ![Trigger] | AlterDir ![Trigger] | TriggerTile ![Trigger] - | StepToTarget + | RunOnceAhead + | MoveOnceToCursor + | RunOnceToCursor + | ContinueToCursor -- Below this line, commands do not take time. | GameRestart !(GroupName ModeKind) | GameExit @@ -56,11 +67,11 @@ | PickLeader !Int | MemberCycle | MemberBack - | DescribeItem !CStore - | AllOwned | SelectActor | SelectNone | Clear + | StopIfTgtMode + | SelectWithPointer | Repeat !Int | Record | History @@ -74,23 +85,31 @@ | MoveCursor !Vector !Int | TgtFloor | TgtEnemy - | TgtUnknown - | TgtItem - | TgtStair !Bool | TgtAscend !Int | EpsIncr !Bool | TgtClear + | CursorUnknown + | CursorItem + | CursorStair !Bool | Cancel | Accept - deriving (Show, Read, Eq, Ord) + | CursorPointerFloor + | CursorPointerEnemy + | TgtPointerFloor + | TgtPointerEnemy + deriving (Show, Read, Eq, Ord, Generic) +instance NFData HumanCmd + data Trigger = ApplyItem {verb :: !MU.Part, object :: !MU.Part, symbol :: !Char} | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !TK.Feature} | TriggerFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !TK.Feature} - deriving (Show, Read, Eq, Ord) + deriving (Show, Read, Eq, Ord, Generic) +instance NFData Trigger + -- | Commands that are forbidden on a remote level, because they -- would usually take time when invoked on one. -- Note that some commands that take time are not included, @@ -101,7 +120,9 @@ MoveItem{} -> True Apply{} -> True AlterDir{} -> True - StepToTarget -> True + MoveOnceToCursor -> True + RunOnceToCursor -> True + ContinueToCursor -> True _ -> False -- | Description of player commands. @@ -113,11 +134,21 @@ MoveItem _ store2 mverb object _ -> let verb = fromMaybe (MU.Text $ verbCStore store2) mverb in makePhrase [verb, object] + DescribeItem (MStore CGround) -> "manage items on the ground" + DescribeItem (MStore COrgan) -> "describe organs of the leader" + DescribeItem (MStore CEqp) -> "manage equipment of the leader" + DescribeItem (MStore CInv) -> "manage inventory pack of the leader" + DescribeItem (MStore CSha) -> "manage the shared party stash" + DescribeItem MOwned -> "describe all owned items" + DescribeItem MStats -> "show the stats summary of the leader" Project ts -> triggerDescription ts Apply ts -> triggerDescription ts AlterDir ts -> triggerDescription ts TriggerTile ts -> triggerDescription ts - StepToTarget -> "make one step towards the target" + RunOnceAhead -> "run once ahead" + MoveOnceToCursor -> "move one step towards the crosshair" + RunOnceToCursor -> "run selected one step towards the crosshair" + ContinueToCursor -> "continue towards the crosshair" GameRestart t -> -- TODO: use mname for the game mode instead of t @@ -131,45 +162,46 @@ PickLeader{} -> "pick leader" MemberCycle -> "cycle among party members on the level" MemberBack -> "cycle among all party members" - DescribeItem CGround -> "describe items on the ground" - DescribeItem COrgan -> "describe organs" - DescribeItem CEqp -> "describe equipment of the leader" - DescribeItem CInv -> "describe backpack inventory of the leader" - DescribeItem CSha -> "describe the shared party stash" - AllOwned -> "describe all owned items" SelectActor -> "select (or deselect) a party member" SelectNone -> "deselect (or select) all on the level" Clear -> "clear messages" + StopIfTgtMode -> "stop playback if in aiming mode" + SelectWithPointer -> "select actors if pointer over actor list" Repeat 1 -> "voice again the recorded commands" Repeat n -> "voice the recorded commands" <+> tshow n <+> "times" Record -> "start recording commands" History -> "display player diary" - MarkVision -> "mark visible zone" - MarkSmell -> "mark smell clues" - MarkSuspect -> "mark suspect terrain" + MarkVision -> "toggle visible zone display" + MarkSmell -> "toggle smell clues display" + MarkSuspect -> "toggle suspect terrain display" Help -> "display help" MainMenu -> "display the Main Menu" Macro t _ -> t - MoveCursor v 1 -> "move cursor" <+> compassText v + MoveCursor v 1 -> "move crosshair" <+> compassText v MoveCursor v k -> - "move cursor up to" <+> tshow k <+> "steps" <+> compassText v - TgtFloor -> "cycle targeting mode" - TgtEnemy -> "target enemy" - TgtUnknown -> "target the closest unknown spot" - TgtItem -> "target the closest item" - TgtStair up -> "target the closest stairs" <+> if up then "up" else "down" - TgtAscend k | k == 1 -> "target next shallower level" - TgtAscend k | k >= 2 -> "target" <+> tshow k <+> "levels shallower" - TgtAscend k | k == -1 -> "target next deeper level" - TgtAscend k | k <= -2 -> "target" <+> tshow (-k) <+> "levels deeper" - TgtAscend _ -> assert `failure` "void level change when targeting" + "move crosshair up to" <+> tshow k <+> "steps" <+> compassText v + TgtFloor -> "cycle aiming styles" + TgtEnemy -> "aim at an enemy" + TgtAscend k | k == 1 -> "aim at next shallower level" + TgtAscend k | k >= 2 -> "aim at" <+> tshow k <+> "levels shallower" + TgtAscend k | k == -1 -> "aim at next deeper level" + TgtAscend k | k <= -2 -> "aim at" <+> tshow (-k) <+> "levels deeper" + TgtAscend _ -> assert `failure` "void level change when aiming" `twith` cmd - EpsIncr True -> "swerve targeting line" - EpsIncr False -> "unswerve targeting line" - TgtClear -> "clear target/cursor" - Cancel -> "cancel action, open Main Menu" - Accept -> "accept choice" + EpsIncr True -> "swerve the aiming line" + EpsIncr False -> "unswerve the aiming line" + TgtClear -> "reset target/crosshair" + CursorUnknown -> "set crosshair to the closest unknown spot" + CursorItem -> "set crosshair to the closest item" + CursorStair up -> "set crosshair to the closest stairs" + <+> if up then "up" else "down" + Cancel -> "cancel action, open Main Menu" + Accept -> "accept target/choice" + CursorPointerFloor -> "set crosshair to floor under pointer" + CursorPointerEnemy -> "set crosshair to enemy under pointer" + TgtPointerFloor -> "enter aiming mode and describe a tile" + TgtPointerEnemy -> "enter aiming mode and describe an enemy" triggerDescription :: [Trigger] -> Text triggerDescription [] = "trigger a thing" diff --git a/Game/LambdaHack/Client/UI/InventoryClient.hs b/Game/LambdaHack/Client/UI/InventoryClient.hs --- a/Game/LambdaHack/Client/UI/InventoryClient.hs +++ b/Game/LambdaHack/Client/UI/InventoryClient.hs @@ -1,415 +1,1021 @@ --- | Inventory management and party cycling. --- TODO: document -module Game.LambdaHack.Client.UI.InventoryClient - ( failMsg, getGroupItem, getAnyItem, getStoreItem - , memberCycle, memberBack, pickLeader - ) where - -import Control.Exception.Assert.Sugar -import Control.Monad -import qualified Data.Char as Char -import qualified Data.EnumMap.Strict as EM -import Data.Function -import qualified Data.IntMap.Strict as IM -import Data.List -import Data.Maybe -import Data.Monoid -import Data.Text (Text) -import qualified Data.Text as T -import qualified NLP.Miniutter.English as MU - -import Game.LambdaHack.Client.CommonClient -import Game.LambdaHack.Client.ItemSlot -import qualified Game.LambdaHack.Client.Key as K -import Game.LambdaHack.Client.MonadClient -import Game.LambdaHack.Client.State -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.MsgClient -import Game.LambdaHack.Client.UI.WidgetClient -import Game.LambdaHack.Common.Actor -import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.Misc -import Game.LambdaHack.Common.MonadStateRead -import Game.LambdaHack.Common.Msg -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.State - -failMsg :: MonadClientUI m => Msg -> m Slideshow -failMsg msg = do - stopPlayBack - assert (not $ T.null msg) $ promptToSlideshow msg - --- | Let a human player choose any item from a given group. --- Note that this does not guarantee the chosen item belongs to the group, --- as the player can override the choice. -getGroupItem :: MonadClientUI m - => (ItemFull -> Bool) -- ^ which items to consider suitable - -> Text -- ^ specific prompt for only suitable items - -> Text -- ^ generic prompt - -> [CStore] -- ^ initial legal containers - -> [CStore] -- ^ legal containers after Calm taken into account - -> m (SlideOrCmd ((ItemId, ItemFull), Container)) -getGroupItem psuit prompt promptGeneric cLegalRaw cLegalAfterCalm = do - side <- getsClient sside - leader <- getLeaderUI - let aidNotEmpty store aid = do - bag <- getsState $ getCBag (CActor aid store) - return $! not $ EM.null bag - partyNotEmpty store = do - as <- getsState $ fidActorNotProjAssocs side - bs <- mapM (aidNotEmpty store . fst) as - return $! or bs - -- Don't display stores empty for all actors - cLegalNotEmpty <- filterM partyNotEmpty cLegalAfterCalm - -- Move a store that is empty for this actor to the back. - getCStoreBag <- getsState $ \s cstore -> getCBag (CActor leader cstore) s - let hasThisActor = not . EM.null . getCStoreBag - cLegal = case find hasThisActor cLegalAfterCalm of - Nothing -> cLegalNotEmpty - Just cThisActor -> cThisActor : delete cThisActor cLegalNotEmpty - getItem psuit (\_ _ _ -> prompt) (\_ _ _ -> promptGeneric) - (map (CActor leader) cLegalRaw) - (map (CActor leader) cLegal) - True INone - --- | Let the human player choose any item from a list of items --- and let him specify the number of items. -getAnyItem :: MonadClientUI m - => MU.Part -- ^ the verb describing the action - -> [CStore] -- ^ initial legal containers - -> [CStore] -- ^ legal containers after Calm taken into account - -> Bool -- ^ whether to ask, when the only item - -- in the starting container is suitable - -> Bool -- ^ whether to ask for the number of items - -> m (SlideOrCmd ((ItemId, ItemFull), Container)) -getAnyItem verb cLegalRaw cLegalAfterCalm askWhenLone askNumber = do - leader <- getLeaderUI - let prompt = makePhrase ["What to", verb] - soc <- getItem (const True) (\_ _ _ -> prompt) (\_ _ _ -> prompt) - (map (CActor leader) cLegalRaw) - (map (CActor leader) cLegalAfterCalm) - askWhenLone ISuitable - case soc of - Left _ -> return soc - Right ((iid, itemFull), c) -> do - socK <- pickNumber askNumber $ itemK itemFull - case socK of - Left slides -> return $ Left slides - Right k -> - return $ Right ((iid, itemFull{itemK=k}), c) - --- | Display all items from a store and let the human player choose any --- or switch to any other store. -getStoreItem :: MonadClientUI m - => (Actor -> [ItemFull] -> Container -> Text) - -- ^ how to describe suitable items - -> Container -- ^ initial container - -> Bool -- ^ whether Enter should be disabled - -> m (SlideOrCmd ((ItemId, ItemFull), Container)) -getStoreItem prompt cInitial noEnter = do - leader <- getLeaderUI - let allStores = map (CActor leader) [CEqp, CInv, CSha, CGround] - cLegalRaw = cInitial : delete cInitial allStores - dialogState = if noEnter then INoEnter else ISuitable - getItem (const True) prompt prompt cLegalRaw cLegalRaw - True dialogState - -data ItemDialogState = INone | ISuitable | IAll | INoEnter - deriving (Show, Eq) - --- | Let the human player choose a single, preferably suitable, --- item from a list of items. -getItem :: MonadClientUI m - => (ItemFull -> Bool) -- ^ which items to consider suitable - -> (Actor -> [ItemFull] -> Container -> Text) - -- ^ specific prompt for only suitable items - -> (Actor -> [ItemFull] -> Container -> Text) - -- ^ generic prompt - -> [Container] -- ^ initial legal containers - -> [Container] -- ^ legal containers with Calm taken into account - -> Bool -- ^ whether to ask, when the only item - -- in the starting container is suitable - -> ItemDialogState -- ^ the dialog state to start in - -> m (SlideOrCmd ((ItemId, ItemFull), Container)) -getItem psuit prompt promptGeneric cLegalRaw cLegal askWhenLone initalState = do - leader <- getLeaderUI - accessCBag <- getsState $ flip getCBag - let storeAssocs = EM.assocs . accessCBag - allAssocs = concatMap storeAssocs cLegal - rawAssocs = concatMap storeAssocs cLegalRaw - mapM_ (updateItemSlot (Just leader)) $ - concatMap (EM.keys . accessCBag) cLegal - case (cLegal, allAssocs) of - ([cStart], [(iid, k)]) | not askWhenLone -> do - itemToF <- itemToFullClient - return $ Right ((iid, itemToF iid k), cStart) - (_ : _, _ : _) -> - transition psuit prompt promptGeneric cLegal initalState - _ -> if null rawAssocs then do - let tLegal = map (MU.Text . ppContainer) cLegalRaw - ppLegal = makePhrase [MU.WWxW "nor" tLegal] - failWith $ "no items" <+> ppLegal - else failSer ItemNotCalm - -data DefItemKey m = DefItemKey - { defLabel :: Text -- ^ can be undefined if not @defCond@ - , defCond :: !Bool - , defAction :: K.Key -> m (SlideOrCmd ((ItemId, ItemFull), Container)) - } - -transition :: forall m. MonadClientUI m - => (ItemFull -> Bool) -- ^ which items to consider suitable - -> (Actor -> [ItemFull] -> Container -> Text) - -- ^ specific prompt for only suitable items - -> (Actor -> [ItemFull] -> Container -> Text) - -- ^ generic prompt - -> [Container] - -> ItemDialogState - -> m (SlideOrCmd ((ItemId, ItemFull), Container)) -transition _ _ _ [] iDS = assert `failure` iDS -transition psuit prompt promptGeneric cLegal@(cCur:cRest) itemDialogState = do - (letterSlots, numberSlots) <- getsClient sslots - leader <- getLeaderUI - body <- getsState $ getActorBody leader - activeItems <- activeItemsClient leader - fact <- getsState $ (EM.! bfid body) . sfactionD - hs <- partyAfterLeader leader - bag <- getsState $ getCBag cCur - itemToF <- itemToFullClient - let getResult :: ItemId -> ((ItemId, ItemFull), Container) - getResult iid = ((iid, itemToF iid (bag EM.! iid)), cCur) - filterP iid kit = psuit $ itemToF iid kit - bagSuit = EM.filterWithKey filterP bag - bagLetterSlots = EM.filter (`EM.member` bag) letterSlots - bagNumberSlots = IM.filter (`EM.member` bag) numberSlots - suitableLetterSlots = EM.filter (`EM.member` bagSuit) letterSlots - (autoDun, autoLvl) = autoDungeonLevel fact - normalizeState INoEnter = INone - normalizeState x = x - keyDefs :: [(K.Key, DefItemKey m)] - keyDefs = filter (defCond . snd) - [ (K.Char '?', DefItemKey - { defLabel = "?" - , defCond = True - , defAction = \_ -> case normalizeState itemDialogState of - INone -> - if EM.null bagSuit - then transition psuit prompt promptGeneric cLegal IAll - else transition psuit prompt promptGeneric cLegal ISuitable - ISuitable | bag /= bagSuit -> - transition psuit prompt promptGeneric cLegal IAll - _ -> transition psuit prompt promptGeneric cLegal INone - }) - , (K.Char '/', DefItemKey - { defLabel = "/" - , defCond = length cLegal > 1 - , defAction = \_ -> - transition psuit prompt promptGeneric - (cRest ++ [cCur]) (normalizeState itemDialogState) - }) - , (K.Return, - let enterSlots = if itemDialogState == IAll - then bagLetterSlots - else suitableLetterSlots - in DefItemKey - { defLabel = case EM.maxViewWithKey enterSlots of - Nothing -> assert `failure` "no suitable items" - `twith` enterSlots - Just ((l, _), _) -> "RET(" <> T.singleton (slotChar l) <> ")" - , defCond = not (EM.null enterSlots - || itemDialogState == INoEnter) - , defAction = \_ -> case EM.maxView enterSlots of - Nothing -> assert `failure` "no suitable items" - `twith` enterSlots - Just (iid, _) -> return $ Right $ getResult iid - }) - , (K.Char '0', DefItemKey -- TODO: accept any number and pick the item - { defLabel = "0" - , defCond = not $ IM.null bagNumberSlots - , defAction = \_ -> case IM.minView bagNumberSlots of - Nothing -> assert `failure` "no numbered items" - `twith` bagNumberSlots - Just (iid, _) -> return $ Right $ getResult iid - }) - , (K.Tab, DefItemKey - { defLabel = "TAB" - , defCond = not (autoLvl - || null (filter (\(_, b) -> - blid b == blid body) hs)) - , defAction = \_ -> do - err <- memberCycle False - assert (err == mempty `blame` err) skip - newLeader <- getLeaderUI - let newC c = case c of - CActor _ cstore -> CActor newLeader cstore - _ -> c - newLegal = map newC cLegal - accessCBag <- getsState $ flip getCBag - mapM_ (updateItemSlot (Just newLeader)) $ - concatMap (EM.keys . accessCBag) newLegal - transition psuit prompt promptGeneric newLegal itemDialogState - }) - , (K.BackTab, DefItemKey - { defLabel = "SHIFT-TAB" - , defCond = not (autoDun || null hs) - , defAction = \_ -> do - err <- memberBack False - assert (err == mempty `blame` err) skip - newLeader <- getLeaderUI - let newC c = case c of - CActor _ cstore -> CActor newLeader cstore - _ -> c - newLegal = map newC cLegal - accessCBag <- getsState $ flip getCBag - mapM_ (updateItemSlot (Just newLeader)) $ - concatMap (EM.keys . accessCBag) newLegal - transition psuit prompt promptGeneric newLegal itemDialogState - }) - ] - lettersDef :: DefItemKey m - lettersDef = DefItemKey - { defLabel = slotRange $ EM.keys labelLetterSlots - , defCond = True - , defAction = \key -> case key of - K.Char l -> case EM.lookup (SlotChar l) bagLetterSlots of - Nothing -> assert `failure` "unexpected slot" - `twith` (l, bagLetterSlots) - Just iid -> return $ Right $ getResult iid - _ -> assert `failure` "unexpected key:" `twith` K.showKey key - } - ppCur = ppContainer cCur - (labelLetterSlots, bagFiltered, promptChosen) = - case itemDialogState of - ISuitable -> (suitableLetterSlots, - bagSuit, - prompt body activeItems cCur <+> ppCur <> ":") - IAll -> (bagLetterSlots, - bag, - promptGeneric body activeItems cCur <+> ppCur <> ":") - _ -> (suitableLetterSlots, - EM.empty, - prompt body activeItems cCur <+> ppCur <> ":") - io <- itemOverlay cCur (blid body) bagFiltered - runDefItemKey keyDefs lettersDef io bagLetterSlots promptChosen - -runDefItemKey :: MonadClientUI m - => [(K.Key, DefItemKey m)] - -> DefItemKey m - -> Overlay - -> EM.EnumMap SlotChar ItemId - -> Text - -> m (SlideOrCmd ((ItemId, ItemFull), Container)) -runDefItemKey keyDefs lettersDef io labelLetterSlots prompt = do - let itemKeys = - let slotKeys = map (K.Char . slotChar) (EM.keys labelLetterSlots) - defKeys = map fst keyDefs - in zipWith K.KM (repeat K.NoModifier) $ slotKeys ++ defKeys - choice = let letterRange = defLabel lettersDef - letterLabel | T.null letterRange = [] - | otherwise = [letterRange] - keyLabels = letterLabel ++ map (defLabel . snd) keyDefs - in "[" <> T.intercalate ", " keyLabels - akm <- displayChoiceUI (prompt <+> choice) io itemKeys - case akm of - Left slides -> failSlides slides - Right K.KM{..} -> do - assert (modifier == K.NoModifier) skip - case lookup key keyDefs of - Just keyDef -> defAction keyDef key - Nothing -> defAction lettersDef key - -pickNumber :: MonadClientUI m => Bool -> Int -> m (SlideOrCmd Int) -pickNumber askNumber kAll = do - let kDefault = kAll - if askNumber && kAll > 1 then do - let tDefault = tshow kDefault - kbound = min 9 kAll - kprompt = "Choose number [1-" <> tshow kbound - <> ", RET(" <> tDefault <> ")" - kkeys = zipWith K.KM (repeat K.NoModifier) - $ map (K.Char . Char.intToDigit) [1..kbound] - ++ [K.Return] - kkm <- displayChoiceUI kprompt emptyOverlay kkeys - case kkm of - Left slides -> failSlides slides - Right K.KM{key} -> - case key of - K.Char l -> return $ Right $ Char.digitToInt l - K.Return -> return $ Right kDefault - _ -> assert `failure` "unexpected key:" `twith` kkm - else return $ Right kAll - --- | Switches current member to the next on the level, if any, wrapping. -memberCycle :: MonadClientUI m => Bool -> m Slideshow -memberCycle verbose = do - side <- getsClient sside - fact <- getsState $ (EM.! side) . sfactionD - leader <- getLeaderUI - body <- getsState $ getActorBody leader - hs <- partyAfterLeader leader - let autoLvl = snd $ autoDungeonLevel fact - case filter (\(_, b) -> blid b == blid body) hs of - _ | autoLvl -> failMsg $ showReqFailure NoChangeLvlLeader - [] -> failMsg "Cannot pick any other member on this level." - (np, b) : _ -> do - success <- pickLeader verbose np - assert (success `blame` "same leader" `twith` (leader, np, b)) skip - return mempty - --- | Switches current member to the previous in the whole dungeon, wrapping. -memberBack :: MonadClientUI m => Bool -> m Slideshow -memberBack verbose = do - side <- getsClient sside - fact <- getsState $ (EM.! side) . sfactionD - leader <- getLeaderUI - hs <- partyAfterLeader leader - let autoDun = fst $ autoDungeonLevel fact - case reverse hs of - _ | autoDun -> failMsg $ showReqFailure NoChangeDunLeader - [] -> failMsg "No other member in the party." - (np, b) : _ -> do - success <- pickLeader verbose np - assert (success `blame` "same leader" `twith` (leader, np, b)) skip - return mempty - -partyAfterLeader :: MonadStateRead m => ActorId -> m [(ActorId, Actor)] -partyAfterLeader leader = do - faction <- getsState $ bfid . getActorBody leader - allA <- getsState $ EM.assocs . sactorD - s <- getState - let hs9 = mapMaybe (tryFindHeroK s faction) [0..9] - factionA = filter (\(_, body) -> - not (bproj body) && bfid body == faction) allA - hs = hs9 ++ deleteFirstsBy ((==) `on` fst) factionA hs9 - i = fromMaybe (-1) $ findIndex ((== leader) . fst) hs - (lt, gt) = (take i hs, drop (i + 1) hs) - return $! gt ++ lt - --- | Select a faction leader. False, if nothing to do. -pickLeader :: MonadClientUI m => Bool -> ActorId -> m Bool -pickLeader verbose aid = do - leader <- getLeaderUI - stgtMode <- getsClient stgtMode - if leader == aid - then return False -- already picked - else do - pbody <- getsState $ getActorBody aid - assert (not (bproj pbody) `blame` "projectile chosen as the leader" - `twith` (aid, pbody)) skip - -- Even if it's already the leader, give his proper name, not 'you'. - let subject = partActor pbody - when verbose $ msgAdd $ makeSentence [subject, "picked as a leader"] - -- Update client state. - s <- getState - modifyClient $ updateLeader aid s - -- Move the cursor, if active, to the new level. - case stgtMode of - Nothing -> return () - Just _ -> - modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode $ blid pbody} - -- Inform about items, etc. - lookMsg <- lookAt False "" True (bpos pbody) aid "" - when verbose $ msgAdd lookMsg - return True +{-# LANGUAGE DataKinds #-} +-- | Inventory management and party cycling. +-- TODO: document +module Game.LambdaHack.Client.UI.InventoryClient + ( Suitability(..) + , getGroupItem, getAnyItems, getStoreItem + , memberCycle, memberBack, pickLeader + , cursorPointerFloor, cursorPointerEnemy + , moveCursorHuman, tgtFloorHuman, tgtEnemyHuman, epsIncrHuman, tgtClearHuman + , doLook, describeItemC + ) where + +import Control.Applicative +import Control.Exception.Assert.Sugar +import Control.Monad +import Data.Char (intToDigit) +import qualified Data.Char as Char +import qualified Data.EnumMap.Strict as EM +import qualified Data.EnumSet as ES +import Data.List +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Monoid +import Data.Ord +import Data.Text (Text) +import qualified Data.Text as T +import qualified NLP.Miniutter.English as MU + +import Game.LambdaHack.Client.CommonClient +import Game.LambdaHack.Client.ItemSlot +import qualified Game.LambdaHack.Client.Key as K +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI.HumanCmd +import Game.LambdaHack.Client.UI.KeyBindings +import Game.LambdaHack.Client.UI.MonadClientUI +import Game.LambdaHack.Client.UI.MsgClient +import Game.LambdaHack.Client.UI.WidgetClient +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.ItemDescription +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.Msg +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.Request +import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Vector +import qualified Game.LambdaHack.Content.ItemKind as IK + +data ItemDialogState = ISuitable | IAll | INoSuitable | INoAll + deriving (Show, Eq) + +ppItemDialogMode :: ItemDialogMode -> (Text, Text) +ppItemDialogMode (MStore cstore) = ppCStore cstore +ppItemDialogMode MOwned = ("in", "our possession") +ppItemDialogMode MStats = ("among", "strenghts") + +ppItemDialogModeIn :: ItemDialogMode -> Text +ppItemDialogModeIn c = let (tIn, t) = ppItemDialogMode c in tIn <+> t + +ppItemDialogModeFrom :: ItemDialogMode -> Text +ppItemDialogModeFrom c = let (_tIn, t) = ppItemDialogMode c in "from" <+> t + +storeFromMode :: ItemDialogMode -> CStore +storeFromMode c = case c of + MStore cstore -> cstore + MOwned -> CGround -- needed to decide display mode in textAllAE + MStats -> CGround -- needed to decide display mode in textAllAE + +accessModeBag :: ActorId -> State -> ItemDialogMode -> ItemBag +accessModeBag leader s (MStore cstore) = getActorBag leader cstore s +accessModeBag leader s MOwned = let fid = bfid $ getActorBody leader s + in sharedAllOwnedFid False fid s +accessModeBag _ _ MStats = EM.empty + +-- | Let a human player choose any item from a given group. +-- Note that this does not guarantee the chosen item belongs to the group, +-- as the player can override the choice. +-- Used e.g., for applying and projecting. +getGroupItem :: MonadClientUI m + => m Suitability + -- ^ which items to consider suitable + -> Text -- ^ specific prompt for only suitable items + -> Text -- ^ generic prompt + -> Bool -- ^ whether to enable setting cursor with mouse + -> [CStore] -- ^ initial legal modes + -> [CStore] -- ^ legal modes after Calm taken into account + -> m (SlideOrCmd ((ItemId, ItemFull), ItemDialogMode)) +getGroupItem psuit prompt promptGeneric cursor cLegalRaw cLegalAfterCalm = do + let dialogState = if cursor then INoSuitable else ISuitable + soc <- getFull psuit + (\_ _ cCur -> prompt <+> ppItemDialogModeFrom cCur) + (\_ _ cCur -> promptGeneric <+> ppItemDialogModeFrom cCur) + cursor cLegalRaw cLegalAfterCalm True False dialogState + case soc of + Left sli -> return $ Left sli + Right ([(iid, itemFull)], c) -> return $ Right ((iid, itemFull), c) + Right _ -> assert `failure` soc + +-- | Let the human player choose any item from a list of items +-- and let him specify the number of items. +-- Used, e.g., for picking up and inventory manipulation. +getAnyItems :: MonadClientUI m + => MU.Part -- ^ the verb describing the action + -> [CStore] -- ^ initial legal modes + -> [CStore] -- ^ legal modes after Calm taken into account + -> Bool -- ^ whether to ask, when the only item + -- in the starting mode is suitable + -> Bool -- ^ whether to ask for the number of items + -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode)) +getAnyItems verb cLegalRaw cLegalAfterCalm askWhenLone askNumber = do + let prompt _ _ cCur = + makePhrase ["What to", verb, MU.Text $ ppItemDialogModeFrom cCur] + soc <- getFull (return SuitsEverything) + prompt prompt False + cLegalRaw cLegalAfterCalm + askWhenLone True ISuitable + case soc of + Left _ -> return soc + Right ([(iid, itemFull)], c) -> do + socK <- pickNumber askNumber $ itemK itemFull + case socK of + Left slides -> return $ Left slides + Right k -> + return $ Right ([(iid, itemFull{itemK=k})], c) + Right _ -> return soc + +-- | Display all items from a store and let the human player choose any +-- or switch to any other store. +-- Used, e.g., for viewing inventory and item descriptions. +getStoreItem :: MonadClientUI m + => (Actor -> [ItemFull] -> ItemDialogMode -> Text) + -- ^ how to describe suitable items + -> ItemDialogMode -- ^ initial mode + -> m (SlideOrCmd ((ItemId, ItemFull), ItemDialogMode)) +getStoreItem prompt cInitial = do + let allCs = map MStore [CEqp, CInv, CSha] + ++ [MOwned] + ++ map MStore [CGround, COrgan] + ++ [MStats] + (pre, rest) = break (== cInitial) allCs + post = dropWhile (== cInitial) rest + remCs = post ++ pre + soc <- getItem (return SuitsEverything) + prompt prompt False cInitial remCs + True False (cInitial:remCs) ISuitable + case soc of + Left sli -> return $ Left sli + Right ([(iid, itemFull)], c) -> return $ Right ((iid, itemFull), c) + Right _ -> assert `failure` soc + +-- | Let the human player choose a single, preferably suitable, +-- item from a list of items. Don't display stores empty for all actors. +-- Start with a non-empty store. +getFull :: MonadClientUI m + => m Suitability + -- ^ which items to consider suitable + -> (Actor -> [ItemFull] -> ItemDialogMode -> Text) + -- ^ specific prompt for only suitable items + -> (Actor -> [ItemFull] -> ItemDialogMode -> Text) + -- ^ generic prompt + -> Bool -- ^ whether to enable setting cursor with mouse + -> [CStore] -- ^ initial legal modes + -> [CStore] -- ^ legal modes with Calm taken into account + -> Bool -- ^ whether to ask, when the only item + -- in the starting mode is suitable + -> Bool -- ^ whether to permit multiple items as a result + -> ItemDialogState -- ^ the dialog state to start in + -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode)) +getFull psuit prompt promptGeneric cursor cLegalRaw cLegalAfterCalm + askWhenLone permitMulitple initalState = do + side <- getsClient sside + leader <- getLeaderUI + let aidNotEmpty store aid = do + bag <- getsState $ getCBag (CActor aid store) + return $! not $ EM.null bag + partyNotEmpty store = do + as <- getsState $ fidActorNotProjAssocs side + bs <- mapM (aidNotEmpty store . fst) as + return $! or bs + mpsuit <- psuit + let psuitFun = case mpsuit of + SuitsEverything -> const True + SuitsNothing _ -> const False + SuitsSomething f -> f + -- Move the first store that is non-empty for suitable items for this actor + -- to the front, if any. + getCStoreBag <- getsState $ \s cstore -> getCBag (CActor leader cstore) s + let hasThisActor = not . EM.null . getCStoreBag + case filter hasThisActor cLegalAfterCalm of + [] -> + if isNothing (find hasThisActor cLegalRaw) then do + let contLegalRaw = map MStore cLegalRaw + tLegal = map (MU.Text . ppItemDialogModeIn) contLegalRaw + ppLegal = makePhrase [MU.WWxW "nor" tLegal] + failWith $ "no items" <+> ppLegal + else failSer ItemNotCalm + haveThis@(headThisActor : _) -> do + itemToF <- itemToFullClient + let suitsThisActor store = + let bag = getCStoreBag store + in any (\(iid, kit) -> psuitFun $ itemToF iid kit) $ EM.assocs bag + cThisActor cDef = case find suitsThisActor haveThis of + Nothing -> cDef + Just cSuits -> cSuits + -- Don't display stores totally empty for all actors. + cLegal <- filterM partyNotEmpty cLegalRaw + let breakStores cInit = + let (pre, rest) = break (== cInit) cLegal + post = dropWhile (== cInit) rest + in (MStore cInit, map MStore $ post ++ pre) + -- The last used store may go before even the first nonempty store. + lastStore <- getsClient slastStore + firstStore <- + if lastStore `notElem` cLegalAfterCalm + then return $! cThisActor headThisActor + else do + (itemSlots, organSlots) <- getsClient sslots + let lSlots = if lastStore == COrgan then organSlots else itemSlots + lastSlot <- getsClient slastSlot + case EM.lookup lastSlot lSlots of + Nothing -> return $! cThisActor headThisActor + Just lastIid -> case EM.lookup lastIid $ getCStoreBag lastStore of + Nothing -> return $! cThisActor headThisActor + Just kit -> do + let lastItemFull = itemToF lastIid kit + lastSuits = psuitFun lastItemFull + cLast = cThisActor lastStore + return $! if lastSuits && cLast /= CGround + then lastStore + else cLast + let (modeFirst, modeRest) = breakStores firstStore + getItem psuit prompt promptGeneric cursor modeFirst modeRest + askWhenLone permitMulitple (map MStore $ cLegal) initalState + +-- | Let the human player choose a single, preferably suitable, +-- item from a list of items. +getItem :: MonadClientUI m + => m Suitability + -- ^ which items to consider suitable + -> (Actor -> [ItemFull] -> ItemDialogMode -> Text) + -- ^ specific prompt for only suitable items + -> (Actor -> [ItemFull] -> ItemDialogMode -> Text) + -- ^ generic prompt + -> Bool -- ^ whether to enable setting cursor with mouse + -> ItemDialogMode -- ^ first mode, legal or not + -> [ItemDialogMode] -- ^ the (rest of) legal modes + -> Bool -- ^ whether to ask, when the only item + -- in the starting mode is suitable + -> Bool -- ^ whether to permit multiple items as a result + -> [ItemDialogMode] -- ^ all legal modes + -> ItemDialogState -- ^ the dialog state to start in + -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode)) +getItem psuit prompt promptGeneric cursor cCur cRest askWhenLone permitMulitple + cLegal initalState = do + leader <- getLeaderUI + accessCBag <- getsState $ accessModeBag leader + let storeAssocs = EM.assocs . accessCBag + allAssocs = concatMap storeAssocs (cCur : cRest) + case (cRest, allAssocs) of + ([], [(iid, k)]) | not askWhenLone -> do + itemToF <- itemToFullClient + return $ Right ([(iid, itemToF iid k)], cCur) + _ -> + transition psuit prompt promptGeneric cursor permitMulitple cLegal + 0 cCur cRest initalState + +data DefItemKey m = DefItemKey + { defLabel :: Text -- ^ can be undefined if not @defCond@ + , defCond :: !Bool + , defAction :: K.KM -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode)) + } + +data Suitability = + SuitsEverything + | SuitsNothing Msg + | SuitsSomething (ItemFull -> Bool) + +transition :: forall m. MonadClientUI m + => m Suitability + -> (Actor -> [ItemFull] -> ItemDialogMode -> Text) + -> (Actor -> [ItemFull] -> ItemDialogMode -> Text) + -> Bool + -> Bool + -> [ItemDialogMode] + -> Int + -> ItemDialogMode + -> [ItemDialogMode] + -> ItemDialogState + -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode)) +transition psuit prompt promptGeneric cursor permitMulitple cLegal + numPrefix cCur cRest itemDialogState = do + let recCall = + transition psuit prompt promptGeneric cursor permitMulitple cLegal + (itemSlots, organSlots) <- getsClient sslots + leader <- getLeaderUI + body <- getsState $ getActorBody leader + activeItems <- activeItemsClient leader + fact <- getsState $ (EM.! bfid body) . sfactionD + hs <- partyAfterLeader leader + bagAll <- getsState $ \s -> accessModeBag leader s cCur + lastSlot <- getsClient slastSlot + itemToF <- itemToFullClient + Binding{brevMap} <- askBinding + mpsuit <- psuit -- when throwing, this sets eps and checks cursor validity + (suitsEverything, psuitFun) <- case mpsuit of + SuitsEverything -> return (True, const True) + SuitsNothing err -> do + slides <- promptToSlideshow $ err <+> moreMsg + void $ getInitConfirms ColorFull [] $ slides <> toSlideshow Nothing [[]] + return (False, const False) + -- When throwing, this function takes missile range into accout. + SuitsSomething f -> return (False, f) + let getSingleResult :: ItemId -> (ItemId, ItemFull) + getSingleResult iid = (iid, itemToF iid (bagAll EM.! iid)) + getResult :: ItemId -> ([(ItemId, ItemFull)], ItemDialogMode) + getResult iid = ([getSingleResult iid], cCur) + getMultResult :: [ItemId] -> ([(ItemId, ItemFull)], ItemDialogMode) + getMultResult iids = (map getSingleResult iids, cCur) + filterP iid kit = psuitFun $ itemToF iid kit + bagAllSuit = EM.filterWithKey filterP bagAll + isOrgan = cCur == MStore COrgan + lSlots = if isOrgan then organSlots else itemSlots + bagItemSlotsAll = EM.filter (`EM.member` bagAll) lSlots + -- Predicate for slot matching the current prefix, unless the prefix + -- is 0, in which case we display all slots, even if they require + -- the user to start with number keys to get to them. + -- Could be generalized to 1 if prefix 1x exists, etc., but too rare. + hasPrefixOpen x _ = slotPrefix x == numPrefix || numPrefix == 0 + bagItemSlotsOpen = EM.filterWithKey hasPrefixOpen bagItemSlotsAll + hasPrefix x _ = slotPrefix x == numPrefix + bagItemSlots = EM.filterWithKey hasPrefix bagItemSlotsOpen + bag = EM.fromList $ map (\iid -> (iid, bagAll EM.! iid)) + (EM.elems bagItemSlotsOpen) + suitableItemSlotsAll = EM.filter (`EM.member` bagAllSuit) lSlots + suitableItemSlotsOpen = + EM.filterWithKey hasPrefixOpen suitableItemSlotsAll + suitableItemSlots = EM.filterWithKey hasPrefix suitableItemSlotsOpen + bagSuit = EM.fromList $ map (\iid -> (iid, bagAllSuit EM.! iid)) + (EM.elems suitableItemSlotsOpen) + (autoDun, autoLvl) = autoDungeonLevel fact + multipleSlots = if itemDialogState `elem` [IAll, INoAll] + then bagItemSlotsAll + else suitableItemSlotsAll + keyDefs :: [(K.KM, DefItemKey m)] + keyDefs = filter (defCond . snd) $ + [ (K.toKM K.NoModifier $ K.Char '?', DefItemKey + { defLabel = "?" + , defCond = not (EM.null bag) + , defAction = \_ -> recCall numPrefix cCur cRest + $ case itemDialogState of + INoSuitable -> if EM.null bagSuit then IAll else ISuitable + ISuitable -> if suitsEverything then INoAll else IAll + IAll -> if EM.null bag then INoSuitable else INoAll + INoAll -> if suitsEverything then ISuitable else INoSuitable + }) + , (K.toKM K.NoModifier $ K.Char '/', DefItemKey + { defLabel = "/" + , defCond = not $ null cRest + , defAction = \_ -> do + let calmE = calmEnough body activeItems + mcCur = filter (`elem` cLegal) [cCur] + (cCurAfterCalm, cRestAfterCalm) = case cRest ++ mcCur of + c1@(MStore CSha) : c2 : rest | not calmE -> + (c2, c1 : rest) + [MStore CSha] | not calmE -> assert `failure` cRest + c1 : rest -> (c1, rest) + [] -> assert `failure` cRest + recCall numPrefix cCurAfterCalm cRestAfterCalm itemDialogState + }) + , (K.toKM K.NoModifier $ K.Char '*', DefItemKey + { defLabel = "*" + , defCond = permitMulitple && not (EM.null multipleSlots) + , defAction = \_ -> + let eslots = EM.elems multipleSlots + in return $ Right $ getMultResult eslots + }) + , (K.toKM K.NoModifier K.Return, DefItemKey + { defLabel = if lastSlot `EM.member` labelItemSlotsOpen + then let l = makePhrase [slotLabel lastSlot] + in "RET(" <> l <> ")" -- l is on the screen list + else "RET" + , defCond = not (EM.null labelItemSlotsOpen) + , defAction = \_ -> case EM.lookup lastSlot labelItemSlotsOpen of + Just iid -> return $ Right $ getResult iid + Nothing -> case EM.minViewWithKey labelItemSlotsOpen of + Nothing -> assert `failure` "labelItemSlotsOpen empty" + `twith` labelItemSlotsOpen + Just ((l, _), _) -> do + modifyClient $ \cli -> + cli { slastSlot = l + , slastStore = storeFromMode cCur } + recCall numPrefix cCur cRest itemDialogState + }) + , let km = M.findWithDefault (K.toKM K.NoModifier K.Tab) + MemberCycle brevMap + in (km, DefItemKey + { defLabel = K.showKM km + , defCond = not (cCur == MOwned + || autoLvl + || not (any (\(_, b) -> blid b == blid body) hs)) + , defAction = \_ -> do + err <- memberCycle False + let !_A = assert (err == mempty `blame` err) () + (cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest + recCall numPrefix cCurUpd cRestUpd itemDialogState + }) + , let km = M.findWithDefault (K.toKM K.NoModifier K.BackTab) + MemberBack brevMap + in (km, DefItemKey + { defLabel = K.showKM km + , defCond = not (cCur == MOwned || autoDun || null hs) + , defAction = \_ -> do + err <- memberBack False + let !_A = assert (err == mempty `blame` err) () + (cCurUpd, cRestUpd) <- legalWithUpdatedLeader cCur cRest + recCall numPrefix cCurUpd cRestUpd itemDialogState + }) + , let km = M.findWithDefault (K.toKM K.NoModifier (K.KP '/')) + TgtFloor brevMap + in cursorCmdDef False km tgtFloorHuman + , let hackyCmd = Macro "" ["KP_Divide"] -- no keypad, but arrows enough + km = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress) + hackyCmd brevMap + in cursorCmdDef False km tgtEnemyHuman + , let km = M.findWithDefault (K.toKM K.NoModifier (K.KP '*')) + TgtEnemy brevMap + in cursorCmdDef False km tgtEnemyHuman + , let hackyCmd = Macro "" ["KP_Multiply"] -- no keypad, but arrows OK + km = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress) + hackyCmd brevMap + in cursorCmdDef False km tgtEnemyHuman + , let km = M.findWithDefault (K.toKM K.NoModifier K.BackSpace) + TgtClear brevMap + in cursorCmdDef False km tgtClearHuman + ] + ++ numberPrefixes + ++ [ let plusMinus = K.Char $ if b then '+' else '-' + km = M.findWithDefault (K.toKM K.NoModifier plusMinus) + (EpsIncr b) brevMap + in cursorCmdDef False km (epsIncrHuman b) + | b <- [True, False] + ] + ++ arrows + ++ [ + let km = M.findWithDefault (K.toKM K.NoModifier K.MiddleButtonPress) + CursorPointerEnemy brevMap + in cursorCmdDef False km (cursorPointerEnemy False False) + , let km = M.findWithDefault (K.toKM K.Shift K.MiddleButtonPress) + CursorPointerFloor brevMap + in cursorCmdDef False km (cursorPointerFloor False False) + , let km = M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress) + TgtPointerEnemy brevMap + in cursorCmdDef True km (cursorPointerEnemy True True) + ] + prefixCmdDef d = + (K.toKM K.NoModifier $ K.Char (intToDigit d), DefItemKey + { defLabel = "" + , defCond = True + , defAction = \_ -> + recCall (10 * numPrefix + d) cCur cRest itemDialogState + }) + numberPrefixes = map prefixCmdDef [0..9] + cursorCmdDef verbose km cmd = + (km, DefItemKey + { defLabel = "keypad, mouse" + , defCond = cursor && EM.null bagFiltered + , defAction = \_ -> do + look <- cmd + when verbose $ + void $ getInitConfirms ColorFull [] + $ look <> toSlideshow Nothing [[]] + recCall numPrefix cCur cRest itemDialogState + }) + arrows = + let kCmds = K.moveBinding False False + (`moveCursorHuman` 1) (`moveCursorHuman` 10) + in map (uncurry $ cursorCmdDef False) kCmds + lettersDef :: DefItemKey m + lettersDef = DefItemKey + { defLabel = slotRange $ EM.keys labelItemSlots + , defCond = True + , defAction = \K.KM{key} -> case key of + K.Char l -> case EM.lookup (SlotChar numPrefix l) bagItemSlots of + Nothing -> assert `failure` "unexpected slot" + `twith` (l, bagItemSlots) + Just iid -> return $ Right $ getResult iid + _ -> assert `failure` "unexpected key:" `twith` K.showKey key + } + (labelItemSlotsOpen, labelItemSlots, bagFiltered, promptChosen) = + case itemDialogState of + ISuitable -> (suitableItemSlotsOpen, + suitableItemSlots, + bagSuit, + prompt body activeItems cCur <> ":") + IAll -> (bagItemSlotsOpen, + bagItemSlots, + bag, + promptGeneric body activeItems cCur <> ":") + INoSuitable -> (suitableItemSlotsOpen, + suitableItemSlots, + EM.empty, + prompt body activeItems cCur <> ":") + INoAll -> (bagItemSlotsOpen, + bagItemSlots, + EM.empty, + promptGeneric body activeItems cCur <> ":") + io <- case cCur of + MStats -> statsOverlay leader -- TODO: describe each stat when selected + _ -> itemOverlay (storeFromMode cCur) (blid body) bagFiltered + runDefItemKey keyDefs lettersDef io bagItemSlots promptChosen + +statsOverlay :: MonadClient m => ActorId -> m Overlay +statsOverlay aid = do + b <- getsState $ getActorBody aid + activeItems <- activeItemsClient aid + let block n = n + if braced b then 50 else 0 + prSlot :: (IK.EqpSlot, Int -> Text) -> Text + prSlot (eqpSlot, f) = + let fullText t = + " " + <> makePhrase [ MU.Text $ T.justifyLeft 22 ' ' + $ IK.slotName eqpSlot + , MU.Text t ] + <> " " + valueText = f $ sumSlotNoFilter eqpSlot activeItems + in fullText valueText + -- Some values can be negative, for others 0 is equivalent but shorter. + slotList = -- TODO: [IK.EqpSlotAddHurtMelee..IK.EqpSlotAddLight] + [ (IK.EqpSlotAddHurtMelee, \t -> tshow t <> "%") + -- TODO: not applicable right now, IK.EqpSlotAddHurtRanged + , (IK.EqpSlotAddArmorMelee, \t -> "[" <> tshow (block t) <> "%]") + , (IK.EqpSlotAddArmorRanged, \t -> "{" <> tshow (block t) <> "%}") + , (IK.EqpSlotAddMaxHP, \t -> tshow $ max 0 t) + , (IK.EqpSlotAddMaxCalm, \t -> tshow $ max 0 t) + , (IK.EqpSlotAddSpeed, \t -> tshow (max 0 t) <> "m/10s") + , (IK.EqpSlotAddSight, \t -> + tshow (max 0 $ min (fromIntegral $ bcalm b `div` (5 * oneM)) t) + <> "m") + , (IK.EqpSlotAddSmell, \t -> tshow (max 0 t) <> "m") + , (IK.EqpSlotAddLight, \t -> tshow (max 0 t) <> "m") + ] + skills = sumSkills activeItems + -- TODO: are negative total skills meaningful? + prAbility :: Ability.Ability -> Text + prAbility ability = + let fullText t = + " " + <> makePhrase [ MU.Text $ T.justifyLeft 22 ' ' + $ "ability" <+> tshow ability + , MU.Text t ] + <> " " + valueText = tshow $ EM.findWithDefault 0 ability skills + in fullText valueText + abilityList = [minBound..maxBound] + return $! toOverlay $ map prSlot slotList ++ map prAbility abilityList + +legalWithUpdatedLeader :: MonadClientUI m + => ItemDialogMode + -> [ItemDialogMode] + -> m (ItemDialogMode, [ItemDialogMode]) +legalWithUpdatedLeader cCur cRest = do + leader <- getLeaderUI + let newLegal = cCur : cRest -- not updated in any way yet + b <- getsState $ getActorBody leader + activeItems <- activeItemsClient leader + let calmE = calmEnough b activeItems + legalAfterCalm = case newLegal of + c1@(MStore CSha) : c2 : rest | not calmE -> (c2, c1 : rest) + [MStore CSha] | not calmE -> (MStore CGround, newLegal) + c1 : rest -> (c1, rest) + [] -> assert `failure` (cCur, cRest) + return legalAfterCalm + +runDefItemKey :: MonadClientUI m + => [(K.KM, DefItemKey m)] + -> DefItemKey m + -> Overlay + -> EM.EnumMap SlotChar ItemId + -> Text + -> m (SlideOrCmd ([(ItemId, ItemFull)], ItemDialogMode)) +runDefItemKey keyDefs lettersDef io labelItemSlots prompt = do + let itemKeys = + let slotKeys = map (K.Char . slotChar) (EM.keys labelItemSlots) + defKeys = map fst keyDefs + in map (K.toKM K.NoModifier) slotKeys ++ defKeys + choice = let letterRange = defLabel lettersDef + keyLabelsRaw = letterRange : map (defLabel . snd) keyDefs + keyLabels = filter (not . T.null) keyLabelsRaw + in "[" <> T.intercalate ", " (nub keyLabels) + akm <- displayChoiceUI (prompt <+> choice) io itemKeys + case akm of + Left slides -> failSlides slides + Right km -> + case lookup km{K.pointer=dummyPoint} keyDefs of + Just keyDef -> defAction keyDef km + Nothing -> defAction lettersDef km + +pickNumber :: MonadClientUI m => Bool -> Int -> m (SlideOrCmd Int) +pickNumber askNumber kAll = do + let kDefault = kAll + if askNumber && kAll > 1 then do + let tDefault = tshow kDefault + kbound = min 9 kAll + kprompt = "Choose number [1-" <> tshow kbound + <> ", RET(" <> tDefault <> ")" + kkeys = map (K.toKM K.NoModifier) + $ map (K.Char . Char.intToDigit) [1..kbound] + ++ [K.Return] + kkm <- displayChoiceUI kprompt emptyOverlay kkeys + case kkm of + Left slides -> failSlides slides + Right K.KM{key} -> + case key of + K.Char l -> return $ Right $ Char.digitToInt l + K.Return -> return $ Right kDefault + _ -> assert `failure` "unexpected key:" `twith` kkm + else return $ Right kAll + +-- | Switches current member to the next on the level, if any, wrapping. +memberCycle :: MonadClientUI m => Bool -> m Slideshow +memberCycle verbose = do + side <- getsClient sside + fact <- getsState $ (EM.! side) . sfactionD + leader <- getLeaderUI + body <- getsState $ getActorBody leader + hs <- partyAfterLeader leader + let autoLvl = snd $ autoDungeonLevel fact + case filter (\(_, b) -> blid b == blid body) hs of + _ | autoLvl -> failMsg $ showReqFailure NoChangeLvlLeader + [] -> failMsg "cannot pick any other member on this level" + (np, b) : _ -> do + success <- pickLeader verbose np + let !_A = assert (success `blame` "same leader" `twith` (leader, np, b)) () + return mempty + +-- | Switches current member to the previous in the whole dungeon, wrapping. +memberBack :: MonadClientUI m => Bool -> m Slideshow +memberBack verbose = do + side <- getsClient sside + fact <- getsState $ (EM.! side) . sfactionD + leader <- getLeaderUI + hs <- partyAfterLeader leader + let autoDun = fst $ autoDungeonLevel fact + case reverse hs of + _ | autoDun -> failMsg $ showReqFailure NoChangeDunLeader + [] -> failMsg "no other member in the party" + (np, b) : _ -> do + success <- pickLeader verbose np + let !_A = assert (success `blame` "same leader" `twith` (leader, np, b)) () + return mempty + +partyAfterLeader :: MonadStateRead m => ActorId -> m [(ActorId, Actor)] +partyAfterLeader leader = do + faction <- getsState $ bfid . getActorBody leader + allA <- getsState $ EM.assocs . sactorD + let factionA = filter (\(_, body) -> + not (bproj body) && bfid body == faction) allA + hs = sortBy (comparing keySelected) factionA + i = fromMaybe (-1) $ findIndex ((== leader) . fst) hs + (lt, gt) = (take i hs, drop (i + 1) hs) + return $! gt ++ lt + +-- | Select a faction leader. False, if nothing to do. +pickLeader :: MonadClientUI m => Bool -> ActorId -> m Bool +pickLeader verbose aid = do + leader <- getLeaderUI + stgtMode <- getsClient stgtMode + if leader == aid + then return False -- already picked + else do + pbody <- getsState $ getActorBody aid + let !_A = assert (not (bproj pbody) + `blame` "projectile chosen as the leader" + `twith` (aid, pbody)) () + -- Even if it's already the leader, give his proper name, not 'you'. + let subject = partActor pbody + when verbose $ msgAdd $ makeSentence [subject, "picked as a leader"] + -- Update client state. + s <- getState + modifyClient $ updateLeader aid s + -- Move the cursor, if active, to the new level. + case stgtMode of + Nothing -> return () + Just _ -> + modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode $ blid pbody} + -- Inform about items, etc. + lookMsg <- lookAt False "" True (bpos pbody) aid "" + when verbose $ msgAdd lookMsg + return True + +cursorPointerFloor :: MonadClientUI m => Bool -> Bool -> m Slideshow +cursorPointerFloor verbose addMoreMsg = do + km <- getsClient slastKM + let newPos@Point{..} = K.pointer km + lidV <- viewedLevel + Level{lxsize, lysize} <- getLevel lidV + if px < 0 || py < 0 || px >= lxsize || py >= lysize then do + stopPlayBack + return mempty + else do + let scursor = TPoint lidV newPos + modifyClient $ \cli -> cli {scursor, stgtMode = Just $ TgtMode lidV} + if verbose then + doLook addMoreMsg + else do + displayPush "" -- flash the targeting line and path + displayDelay -- for a bit longer + return mempty + +cursorPointerEnemy :: MonadClientUI m => Bool -> Bool -> m Slideshow +cursorPointerEnemy verbose addMoreMsg = do + km <- getsClient slastKM + let newPos@Point{..} = K.pointer km + lidV <- viewedLevel + Level{lxsize, lysize} <- getLevel lidV + if px < 0 || py < 0 || px >= lxsize || py >= lysize then do + stopPlayBack + return mempty + else do + bsAll <- getsState $ actorAssocs (const True) lidV + let scursor = + case find (\(_, m) -> bpos m == newPos) bsAll of + Just (im, _) -> TEnemy im True + Nothing -> TPoint lidV newPos + modifyClient $ \cli -> cli {scursor, stgtMode = Just $ TgtMode lidV} + if verbose then + doLook addMoreMsg + else do + displayPush "" -- flash the targeting line and path + displayDelay -- for a bit longer + return mempty + +-- | Move the cursor. Assumes targeting mode. +moveCursorHuman :: MonadClientUI m => Vector -> Int -> m Slideshow +moveCursorHuman dir n = do + leader <- getLeaderUI + stgtMode <- getsClient stgtMode + let lidV = maybe (assert `failure` leader) tgtLevelId stgtMode + Level{lxsize, lysize} <- getLevel lidV + lpos <- getsState $ bpos . getActorBody leader + scursor <- getsClient scursor + cursorPos <- cursorToPos + let cpos = fromMaybe lpos cursorPos + shiftB pos = shiftBounded lxsize lysize pos dir + newPos = iterate shiftB cpos !! n + if newPos == cpos then failMsg "never mind" + else do + let tgt = case scursor of + TVector{} -> TVector $ newPos `vectorToFrom` lpos + _ -> TPoint lidV newPos + modifyClient $ \cli -> cli {scursor = tgt} + doLook False + +-- | Cycle targeting mode. Do not change position of the cursor, +-- switch among things at that position. +tgtFloorHuman :: MonadClientUI m => m Slideshow +tgtFloorHuman = do + lidV <- viewedLevel + leader <- getLeaderUI + lpos <- getsState $ bpos . getActorBody leader + cursorPos <- cursorToPos + scursor <- getsClient scursor + stgtMode <- getsClient stgtMode + bsAll <- getsState $ actorAssocs (const True) lidV + let cursor = fromMaybe lpos cursorPos + tgt = case scursor of + _ | isNothing stgtMode -> -- first key press: keep target + scursor + TEnemy a True -> TEnemy a False + TEnemy{} -> TPoint lidV cursor + TEnemyPos{} -> TPoint lidV cursor + TPoint{} -> TVector $ cursor `vectorToFrom` lpos + TVector{} -> + -- For projectiles, we pick here the first that would be picked + -- by '*', so that all other projectiles on the tile come next, + -- without any intervening actors from other tiles. + case find (\(_, m) -> Just (bpos m) == cursorPos) bsAll of + Just (im, _) -> TEnemy im True + Nothing -> TPoint lidV cursor + modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV} + doLook False + +tgtEnemyHuman :: MonadClientUI m => m Slideshow +tgtEnemyHuman = do + lidV <- viewedLevel + leader <- getLeaderUI + lpos <- getsState $ bpos . getActorBody leader + cursorPos <- cursorToPos + scursor <- getsClient scursor + stgtMode <- getsClient stgtMode + side <- getsClient sside + fact <- getsState $ (EM.! side) . sfactionD + bsAll <- getsState $ actorAssocs (const True) lidV + let ordPos (_, b) = (chessDist lpos $ bpos b, bpos b) + dbs = sortBy (comparing ordPos) bsAll + pickUnderCursor = -- switch to the enemy under cursor, if any + let i = fromMaybe (-1) + $ findIndex ((== cursorPos) . Just . bpos . snd) dbs + in splitAt i dbs + (permitAnyActor, (lt, gt)) = case scursor of + TEnemy a permit | isJust stgtMode -> -- pick next enemy + let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs + in (permit, splitAt (i + 1) dbs) + TEnemy a permit -> -- first key press, retarget old enemy + let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs + in (permit, splitAt i dbs) + TEnemyPos _ _ _ permit -> (permit, pickUnderCursor) + _ -> (False, pickUnderCursor) -- the sensible default is only-foes + gtlt = gt ++ lt + isEnemy b = isAtWar fact (bfid b) + && not (bproj b) + lf = filter (isEnemy . snd) gtlt + tgt | permitAnyActor = case gtlt of + (a, _) : _ -> TEnemy a True + [] -> scursor -- no actors in sight, stick to last target + | otherwise = case lf of + (a, _) : _ -> TEnemy a False + [] -> scursor -- no seen foes in sight, stick to last target + -- Register the chosen enemy, to pick another on next invocation. + modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV} + doLook False + +-- | Tweak the @eps@ parameter of the targeting digital line. +epsIncrHuman :: MonadClientUI m => Bool -> m Slideshow +epsIncrHuman b = do + stgtMode <- getsClient stgtMode + if isJust stgtMode + then do + modifyClient $ \cli -> cli {seps = seps cli + if b then 1 else -1} + return mempty + else failMsg "never mind" -- no visual feedback, so no sense + +tgtClearHuman :: MonadClientUI m => m Slideshow +tgtClearHuman = do + leader <- getLeaderUI + tgt <- getsClient $ getTarget leader + case tgt of + Just _ -> do + modifyClient $ updateTarget leader (const Nothing) + return mempty + Nothing -> do + scursorOld <- getsClient scursor + b <- getsState $ getActorBody leader + let scursor = case scursorOld of + TEnemy _ permit -> TEnemy leader permit + TEnemyPos _ _ _ permit -> TEnemy leader permit + TPoint{} -> TPoint (blid b) (bpos b) + TVector{} -> TVector (Vector 0 0) + modifyClient $ \cli -> cli {scursor} + doLook False + +-- | Perform look around in the current position of the cursor. +-- Normally expects targeting mode and so that a leader is picked. +doLook :: MonadClientUI m => Bool -> m Slideshow +doLook addMoreMsg = do + Kind.COps{cotile=Kind.Ops{ouniqGroup}} <- getsState scops + let unknownId = ouniqGroup "unknown space" + stgtMode <- getsClient stgtMode + case stgtMode of + Nothing -> return mempty + Just tgtMode -> do + leader <- getLeaderUI + let lidV = tgtLevelId tgtMode + lvl <- getLevel lidV + cursorPos <- cursorToPos + per <- getPerFid lidV + b <- getsState $ getActorBody leader + let p = fromMaybe (bpos b) cursorPos + canSee = ES.member p (totalVisible per) + inhabitants <- if canSee + then getsState $ posToActors p lidV + else return [] + seps <- getsClient seps + mnewEps <- makeLine False b p seps + itemToF <- itemToFullClient + let aims = isJust mnewEps + enemyMsg = case inhabitants of + [] -> "" + ((_, body), _) : rest -> + -- Even if it's the leader, give his proper name, not 'you'. + let subjects = map (partActor . snd . fst) inhabitants + subject = MU.WWandW subjects + verb = "be here" + desc = if not (null rest) -- many actors + then "" + else case itemDisco $ itemToF (btrunk body) (1, []) of + Nothing -> "" + Just ItemDisco{itemKind} -> IK.idesc itemKind + pdesc = if desc == "" then "" else "(" <> desc <> ")" + in makeSentence [MU.SubjectVerbSg subject verb] <+> pdesc + vis | lvl `at` p == unknownId = "that is" + | not canSee = "you remember" + | not aims = "you are aware of" + | otherwise = "you see" + -- Show general info about current position. + lookMsg <- lookAt True vis canSee p leader enemyMsg +{- targeting is kind of a menu (or at least mode), so this is menu inside + a menu, which is messy, hence disabled until UI overhauled: + -- Check if there's something lying around at current position. + is <- getsState $ getCBag $ CFloor lidV p + if EM.size is <= 2 then + promptToSlideshow lookMsg + else do + msgAdd lookMsg -- TODO: do not add to history + floorItemOverlay lidV p +-} + promptToSlideshow $ lookMsg <+> if addMoreMsg then moreMsg else "" + + +-- | Create a list of item names. +_floorItemOverlay :: MonadClientUI m + => LevelId -> Point + -> m (SlideOrCmd (RequestTimed 'Ability.AbMoveItem)) +_floorItemOverlay _lid _p = describeItemC MOwned {-CFloor lid p-} + +describeItemC :: MonadClientUI m + => ItemDialogMode + -> m (SlideOrCmd (RequestTimed 'Ability.AbMoveItem)) +describeItemC c = do + let subject = partActor + verbSha body activeItems = if calmEnough body activeItems + then "notice" + else "paw distractedly" + prompt body activeItems c2 = + let (tIn, t) = ppItemDialogMode c2 + in case c2 of + MStore CGround -> -- TODO: variant for actors without (unwounded) feet + makePhrase + [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "notice" + , MU.Text "at" + , MU.WownW (MU.Text $ bpronoun body) $ MU.Text "feet" ] + MStore CSha -> + makePhrase + [ MU.Capitalize + $ MU.SubjectVerbSg (subject body) (verbSha body activeItems) + , MU.Text tIn + , MU.Text t ] + MStore COrgan -> + makePhrase + [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "feel" + , MU.Text tIn + , MU.WownW (MU.Text $ bpronoun body) $ MU.Text t ] + MOwned -> + makePhrase + [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "recall" + , MU.Text tIn + , MU.Text t ] + MStats -> + makePhrase + [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "estimate" + , MU.WownW (MU.Text $ bpronoun body) $ MU.Text t ] + _ -> + makePhrase + [ MU.Capitalize $ MU.SubjectVerbSg (subject body) "see" + , MU.Text tIn + , MU.WownW (MU.Text $ bpronoun body) $ MU.Text t ] + ggi <- getStoreItem prompt c + case ggi of + Right ((iid, itemFull), c2) -> do + leader <- getLeaderUI + b <- getsState $ getActorBody leader + activeItems <- activeItemsClient leader + let calmE = calmEnough b activeItems + localTime <- getsState $ getLocalTime (blid b) + let io = itemDesc (storeFromMode c2) (blid b) localTime itemFull + case c2 of + MStore COrgan -> do + let symbol = jsymbol (itemBase itemFull) + blurb | symbol == '+' = "drop temporary conditions" + | otherwise = "amputate organs" + -- TODO: also forbid on the server, except in special cases. + Left <$> overlayToSlideshow ("Can't" + <+> blurb + <> ", but here's the description.") io + MStore CSha | not calmE -> do + Left <$> overlayToSlideshow "Not enough calm to take items from the shared stash, but here's the description." io + MStore fromCStore -> do + let prompt2 = "Where to move the item?" + fstores :: [(K.Key, (CStore, Text))] + fstores = + filter ((/= fromCStore) . fst . snd) $ + [ (K.Char 'e', (CEqp, "'e'quipment")) + , (K.Char 'p', (CInv, "inventory 'p'ack")) ] + ++ [ (K.Char 's', (CSha, "shared 's'tash")) | calmE ] + ++ [ (K.Char 'g', (CGround, "'g'round")) ] + choice = "[" <> T.intercalate ", " (map (snd . snd) fstores) + keys = map (K.toKM K.NoModifier . K.Char) "epsg" + akm <- displayChoiceUI (prompt2 <+> choice) io keys + case akm of + Left slides -> failSlides slides + Right km -> do + socK <- pickNumber True $ itemK itemFull + case socK of + Left slides -> return $ Left slides + Right k -> do + let lr toCStore = return $ Right $ ReqMoveItems + [(iid, k, fromCStore, toCStore)] + case lookup (K.key km) fstores of + Just (store, _) -> lr store + Nothing -> return $ Left mempty + MOwned -> do + -- We can't move items from MOwned, because different copies may come + -- from different stores and we can't guess player's intentions. + found <- getsState $ findIid leader (bfid b) iid + let !_A = assert (not (null found) `blame` ggi) () + let ppLoc (_, CSha) = MU.Text $ ppCStoreIn CSha <+> "of the party" + ppLoc (b2, store) = MU.Text $ ppCStoreIn store <+> "of" <+> bname b2 + foundTexts = map ppLoc found + prompt2 = makeSentence ["The item is", MU.WWandW foundTexts] + Left <$> overlayToSlideshow prompt2 io + MStats -> assert `failure` ggi + Left slides -> return $ Left slides 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 @@ -34,13 +34,21 @@ -> Config -- ^ game config -> Binding -- ^ concrete binding stdBinding copsClient !Config{configCommands, configVi, configLaptop} = - let heroSelect k = ( K.KM { key=K.Char (Char.intToDigit k) - , modifier=K.NoModifier } + let heroSelect k = ( K.toKM K.NoModifier (K.Char (Char.intToDigit k)) , ([CmdMeta], PickLeader k) ) cmdWithHelp = rhumanCommands copsClient ++ configCommands cmdAll = cmdWithHelp - ++ [(K.mkKM "KP_Begin", ([CmdMove], Wait))] + ++ [ (K.mkKM "KP_Begin", ([CmdMove], Wait)) + , (K.mkKM "CTRL-KP_Begin", ([CmdMove], Macro "" ["KP_Begin"])) + , (K.mkKM "KP_5", ([CmdMove], Macro "" ["KP_Begin"])) + , (K.mkKM "CTRL-KP_5", ([CmdMove], Macro "" ["KP_Begin"])) ] + ++ (if configVi + then [ (K.mkKM "period", ([CmdMove], Macro "" ["KP_Begin"])) ] + else if configLaptop + then [ (K.mkKM "i", ([CmdMove], Macro "" ["KP_Begin"])) + , (K.mkKM "I", ([CmdMove], Macro "" ["KP_Begin"])) ] + else []) ++ K.moveBinding configVi configLaptop (\v -> ([CmdMove], Move v)) (\v -> ([CmdMove], Run v)) ++ fmap heroSelect [0..6] @@ -48,35 +56,18 @@ in Binding { bcmdMap = M.fromList $ map (second mkDescribed) cmdAll , bcmdList = map (second mkDescribed) cmdWithHelp - , brevMap = M.fromList $ map swap $ map (second snd) cmdAll + , brevMap = M.fromList $ map (swap . second snd) cmdAll } -- | Produce a set of help screens from the key bindings. keyHelp :: Binding -> Slideshow keyHelp Binding{bcmdList} = let - minimalBlurb = - [ "Move throughout a level with numerical keypad or, optionally, other keys." - , "Run ahead (until anything disturbs you) with SHIFT (or CTRL) and a key." - , "" - , " 7 8 9 7 8 9 y k u" - , " \\|/ \\|/ \\|/" - , " 4-5-6 u-i-o h-.-l" - , " /|\\ /|\\ /|\\" - , " 1 2 3 j k l b j n" - , "" - , "Interact with the dungeon using the following basic commands." - , "" - ] - minCatBlurb = - [ "" - , "Press SPACE to see detailed descriptions of all commands." - ] movBlurb = - [ "Move throughout a level with numerical keypad (left diagram)" - , "or its compact laptop replacement (middle) or Vi text editor keys" + [ "Walk throughout a level with mouse or numeric keypad (left diagram)" + , "or its compact laptop replacement (middle) or the Vi text editor keys" , "(right, also known as \"Rogue-like keys\"; can be enabled in config.ui.ini)." - , "Run ahead, until anything disturbs you, with SHIFT (or CTRL) and a key." + , "Run, until disturbed, with left mouse button or SHIFT (or CTRL) and a key." , "" , " 7 8 9 7 8 9 y k u" , " \\|/ \\|/ \\|/" @@ -84,8 +75,8 @@ , " /|\\ /|\\ /|\\" , " 1 2 3 j k l b j n" , "" - , "In targeting mode the very same keys move the targeting cursor." - , "Press '5' or 'i' or '.' to wait, bracing for blows, which reduces" + , "In aiming mode the same keys (or mouse) move the crosshair (the white box)." + , "Press 'KEYPAD_5' (or 'i' or '.') to wait, bracing for blows, which reduces" , "any damage taken and makes it impossible for foes to displace you." , "You displace enemies or friends by bumping into them with SHIFT (or CTRL)." , "" @@ -93,8 +84,20 @@ , "The best item to attack with is automatically chosen from among" , "weapons in your personal equipment and your unwounded organs." , "" - , "Press SPACE to see command descriptions." + , "Press SPACE to see the minimal command set." ] + minimalBlurb = + [ "The following minimal command set lets you accomplish anything in the game," + , "though not neccessarily with the fewest number of keystrokes." + , "Most of the other commands are shorthands, defined as macros" + , "(with the exception of the advanced commands for assigning non-default" + , "tactics and targets to your autonomous henchmen, if you have any)." + , "" + ] + casualEndBlurb = + [ "" + , "Press SPACE to see the detailed descriptions of all commands." + ] categoryBlurb = [ "" , "Press SPACE to see the next page of command descriptions." @@ -102,40 +105,52 @@ lastBlurb = [ "" , "For more playing instructions see file PLAYING.md." - , "Press SPACE to clear the messages and see the map again." + , "Press PGUP to return to previous pages or ESC to see the map again." ] - fmt k h = T.justifyRight 72 ' ' - $ T.justifyLeft 15 ' ' k - <> T.justifyLeft 48 ' ' h + pickLeaderDescription = + [ fmt 16 "0, 1, ... 6" "pick a particular actor as the new leader" + ] + casualDescription = "Minimal cheat sheet for casual play" + fmt n k h = T.justifyRight 72 ' ' + $ T.justifyLeft n ' ' k + <> T.justifyLeft 48 ' ' h fmts s = " " <> T.justifyLeft 71 ' ' s - minimalText = map fmts minimalBlurb movText = map fmts movBlurb - minCatText = map fmts minCatBlurb + minimalText = map fmts minimalBlurb + casualEndText = map fmts casualEndBlurb categoryText = map fmts categoryBlurb lastText = map fmts lastBlurb - keyCaption = fmt "keys" "command" coImage :: K.KM -> [K.KM] coImage k = k : sort [ from - | (from, (_, _, Macro _ [to])) <- bcmdList - , K.mkKM to == k ] + | (from, (_, cats, Macro _ [to])) <- bcmdList + , K.mkKM to == k + , any (`notElem` [CmdDebug, CmdInternal]) cats ] disp k = T.concat $ intersperse " and " $ map K.showKM $ coImage k - keys cat = [ fmt (disp k) h - | (k, (h, cats, _)) <- bcmdList, cat `elem` cats, h /= "" ] - in toSlideshow True - [ [categoryDescription CmdMinimal - <> ". [press SPACE to see all commands]"] ++ [""] - ++ minimalText - ++ [keyCaption] ++ keys CmdMinimal ++ minCatText ++ [moreMsg] - , ["Movement. [press SPACE to advance]"] ++ [""] + keysN n cat = [ fmt n (disp k) h + | (k, (h, cats, _)) <- bcmdList, cat `elem` cats, h /= "" ] + -- TODO: measure the longest key sequence and set the caption automatically + keyCaptionN n = fmt n "keys" "command" + keys = keysN 16 + keyCaption = keyCaptionN 16 + in toSlideshow (Just True) + [ [casualDescription <+> "(1/2). [press SPACE to see more]"] ++ [""] ++ movText ++ [moreMsg] - , [categoryDescription CmdMove <> ". [press SPACE to advance]"] ++ [""] - ++ [keyCaption] ++ keys CmdMove ++ categoryText ++ [moreMsg] + , [casualDescription <+> "(2/2). [press SPACE to see all commands]"] ++ [""] + ++ minimalText + ++ [keyCaption] ++ keys CmdMinimal ++ casualEndText ++ [moreMsg] + , ["All terrain exploration and alteration commands" + <> ". [press SPACE to advance]"] ++ [""] + ++ [keyCaptionN 10] ++ keysN 10 CmdMove ++ categoryText ++ [moreMsg] , [categoryDescription CmdItem <> ". [press SPACE to advance]"] ++ [""] - ++ [keyCaption] ++ keys CmdItem ++ categoryText ++ [moreMsg] + ++ [keyCaptionN 10] ++ keysN 10 CmdItem ++ categoryText ++ [moreMsg] , [categoryDescription CmdTgt <> ". [press SPACE to advance]"] ++ [""] ++ [keyCaption] ++ keys CmdTgt ++ categoryText ++ [moreMsg] , [categoryDescription CmdAuto <> ". [press SPACE to advance]"] ++ [""] ++ [keyCaption] ++ keys CmdAuto ++ categoryText ++ [moreMsg] - , [categoryDescription CmdMeta <> "."] ++ [""] - ++ [keyCaption] ++ keys CmdMeta ++ lastText + , [categoryDescription CmdMeta <> ". [press SPACE to advance]"] ++ [""] + ++ [keyCaption] ++ keys CmdMeta ++ pickLeaderDescription + ++ categoryText ++ [moreMsg] + , [categoryDescription CmdMouse + <> ". [press PGUP to see previous, ESC to cancel]"] ++ [""] + ++ [keyCaptionN 21] ++ keysN 21 CmdMouse ++ lastText ++ [endMsg] ] 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 @@ -9,15 +9,16 @@ -- * Display and key input , ColorMode(..) , promptGetKey, getKeyOverlayCommand, getInitConfirms - , displayFrame, displayDelay, displayFrames, displayActorStart, drawOverlay + , displayFrame, displayDelay, displayActorStart, drawOverlay -- * Assorted primitives - , stopPlayBack, stopRunning, askConfig, askBinding + , stopPlayBack, askConfig, askBinding , syncFrames, setFrontAutoYes, tryTakeMVarSescMVar, scoreToSlideshow , getLeaderUI, getArenaUI, viewedLevel , targetDescLeader, targetDescCursor , leaderTgtToPos, leaderTgtAims, cursorToPos ) where +import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception.Assert.Sugar @@ -26,7 +27,6 @@ import Data.Maybe import Data.Monoid import Data.Text (Text) -import qualified Data.Text as T import qualified NLP.Miniutter.English as MU import System.Time @@ -42,7 +42,6 @@ import Game.LambdaHack.Client.UI.KeyBindings import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState -import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.HighScore as HighScore import Game.LambdaHack.Common.ItemDescription @@ -52,12 +51,14 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Time +import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind -- | The information that is constant across a client playing session, -- including many consecutive games in a single session, -- but is completely disregarded and reset when a new playing session starts. --- Auxiliary AI and computer player clients have no @sfs@ nor @sbinding@. +-- This includes a frontend session and keybinding info. data SessionUI = SessionUI { schanF :: !ChanFrontend -- ^ connection with the frontend , sbinding :: !Binding -- ^ binding of keys to commands @@ -65,6 +66,7 @@ , sconfig :: !Config } +-- | The monad that gives the client access to UI operations. class MonadClient m => MonadClientUI m where getsSession :: (SessionUI -> a) -> m a liftIO :: IO a -> m a @@ -83,28 +85,41 @@ promptGetKey :: MonadClientUI m => [K.KM] -> SingleFrame -> m K.KM promptGetKey frontKM frontFr = do - escPressed <- tryTakeMVarSescMVar -- this also clears the ESC-pressed marker + -- Assume we display the arena when we prompt for a key and possibly + -- insert a delay and reset cutoff. + arena <- getArenaUI + localTime <- getsState $ getLocalTime arena + -- No delay, because this is before the UI actor acts. Ideally the frame + -- would not be changed either. + -- However, set sdisplayed so that there's no extra delay after the actor + -- acts either, because waiting for the key introduces enough delay. + -- Or this is running, etc., which we want fast. + let ageDisp = EM.insert arena localTime + modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli} + escPressed <- tryTakeMVarSescMVar -- this also clears the ESC-pressed marker lastPlayOld <- getsClient slastPlay km <- case lastPlayOld of km : kms | not escPressed && (null frontKM || km `elem` frontKM) -> do - displayFrame True $ Just frontFr + displayFrame $ Just frontFr -- Sync frames so that ESC doesn't skip frames. syncFrames modifyClient $ \cli -> cli {slastPlay = kms} return km _ -> do - unless (null lastPlayOld) stopPlayBack -- we can't continue playback + stopPlayBack -- we can't continue playback; wipe out old srunning writeConnFrontend FrontKey{..} - readConnFrontend + km <- readConnFrontend + modifyClient $ \cli -> cli {slastKM = km} + return km (seqCurrent, seqPrevious, k) <- getsClient slastRecord let slastRecord = (km : seqCurrent, seqPrevious, k) modifyClient $ \cli -> cli {slastRecord} return km -- | Display an overlay and wait for a human player command. -getKeyOverlayCommand :: MonadClientUI m => Bool -> Overlay -> m K.KM +getKeyOverlayCommand :: MonadClientUI m => Maybe Bool -> Overlay -> m K.KM getKeyOverlayCommand onBlank overlay = do - frame <- drawOverlay onBlank ColorFull overlay + frame <- drawOverlay (isJust onBlank) ColorFull overlay promptGetKey [] frame -- | Display a slideshow, awaiting confirmation for each slide except the last. @@ -112,13 +127,10 @@ => ColorMode -> [K.KM] -> Slideshow -> m Bool getInitConfirms dm frontClear slides = do let (onBlank, ovs) = slideshow slides - frontSlides <- drawOverlays onBlank dm ovs - -- The first two cases are optimizations: + frontFromTop = onBlank + frontSlides <- drawOverlays (isJust onBlank) dm ovs case frontSlides of [] -> return True - [x] -> do - displayFrame False $ Just x - return True _ -> do writeConnFrontend FrontSlides{..} km <- readConnFrontend @@ -126,48 +138,50 @@ -- block a ping and the ping would not see the ESC. return $! km /= K.escKM -displayFrame :: MonadClientUI m => Bool -> Maybe SingleFrame -> m () -displayFrame isRunning mf = do +displayFrame :: MonadClientUI m => Maybe SingleFrame -> m () +displayFrame mf = do let frame = case mf of Nothing -> FrontDelay - Just fr | isRunning -> FrontRunningFrame fr Just fr -> FrontNormalFrame fr writeConnFrontend frame displayDelay :: MonadClientUI m => m () -displayDelay = writeConnFrontend FrontDelay - --- | Push frames or delays to the frame queue. -displayFrames :: MonadClientUI m => Frames -> m () -displayFrames = mapM_ (displayFrame False) +displayDelay = sequence_ $ replicate 4 $ writeConnFrontend FrontDelay -- | Push frames or delays to the frame queue. Additionally set @sdisplayed@. -- because animations not always happen after @SfxActorStart@ on the leader's -- level (e.g., death can lead to leader change to another level mid-turn, -- and there could be melee and animations on that level at the same moment). +-- Insert delays, so that the animations don't look rushed. displayActorStart :: MonadClientUI m => Actor -> Frames -> m () displayActorStart b frs = do - mapM_ (displayFrame False) frs - let ageDisp displayed = EM.insert (blid b) (btime b) displayed + timeCutOff <- getsClient $ EM.findWithDefault timeZero (blid b) . sdisplayed + localTime <- getsState $ getLocalTime (blid b) + let delta = localTime `timeDeltaToFrom` timeCutOff + when (delta > Delta timeClip && not (bproj b)) + displayDelay + let ageDisp = EM.insert (blid b) localTime modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli} + mapM_ displayFrame frs -- | Draw the current level with the overlay on top. -drawOverlay :: MonadClientUI m => Bool -> ColorMode -> Overlay -> m SingleFrame +drawOverlay :: MonadClientUI m + => Bool -> ColorMode -> Overlay -> m SingleFrame drawOverlay sfBlank@True _ sfTop = do let sfLevel = [] sfBottom = [] return $! SingleFrame {..} -drawOverlay sfBlank@False dm sfTop = do +drawOverlay False dm sfTop = do lid <- viewedLevel mleader <- getsClient _sleader tgtPos <- leaderTgtToPos cursorPos <- cursorToPos let anyPos = fromMaybe (Point 0 0) cursorPos - pathFromLeader leader = fmap Just $ getCacheBfsAndPath leader anyPos + pathFromLeader leader = Just <$> getCacheBfsAndPath leader anyPos bfsmpath <- maybe (return Nothing) pathFromLeader mleader tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader cursorDesc <- targetDescCursor - draw sfBlank dm lid cursorPos tgtPos bfsmpath cursorDesc tgtDesc sfTop + draw dm lid cursorPos tgtPos bfsmpath cursorDesc tgtDesc sfTop drawOverlays :: MonadClientUI m => Bool -> ColorMode -> [Overlay] -> m [SingleFrame] @@ -183,12 +197,8 @@ { slastPlay = [] , slastRecord = let (seqCurrent, seqPrevious, _) = slastRecord cli in (seqCurrent, seqPrevious, 0) - , swaitTimes = - swaitTimes cli + , swaitTimes = - abs (swaitTimes cli) } - stopRunning - -stopRunning :: MonadClientUI m => m () -stopRunning = do srunning <- getsClient srunning case srunning of Nothing -> return () @@ -202,7 +212,7 @@ s <- getState when (memActor runLeader arena s && not (noRunWithMulti fact)) $ modifyClient $ updateLeader runLeader s - modifyClient (\cli -> cli { srunning = Nothing }) + modifyClient (\cli -> cli {srunning = Nothing}) askConfig :: MonadClientUI m => m Config askConfig = getsSession sconfig @@ -215,9 +225,11 @@ syncFrames :: MonadClientUI m => m () syncFrames = do -- Hack. - writeConnFrontend FrontSlides{frontClear=[], frontSlides=[]} + writeConnFrontend + FrontSlides{frontClear=[], frontSlides=[], frontFromTop=Nothing} km <- readConnFrontend - assert (km == K.spaceKM) skip + let !_A = assert (km == K.spaceKM) () + return () setFrontAutoYes :: MonadClientUI m => Bool -> m () setFrontAutoYes b = writeConnFrontend $ FrontAutoYes b @@ -239,13 +251,17 @@ -- TODO: we should do this, and make sure we do that after server -- saved the updated score table, and not register, but read from it. -- Otherwise the score is not accurate, e.g., the number of victims. - table <- getsState shigh + scoreDict <- getsState shigh + gameModeId <- getsState sgameModeId + gameMode <- getGameMode time <- getsState stime date <- liftIO getClockTime scurDifficulty <- getsClient scurDifficulty factionD <- getsState sfactionD - loots <- factionLoots fid - let showScore (ntable, pos) = HighScore.highSlideshow ntable pos + let table = HighScore.getTable gameModeId scoreDict + gameModeName = mname gameMode + showScore (ntable, pos) = + HighScore.highSlideshow ntable pos gameModeName diff | not $ fhasUI $ gplayer fact = difficultyDefault | otherwise = scurDifficulty theirVic (fi, fa) | isAtWar fact fi @@ -258,7 +274,8 @@ (worthMentioning, rScore) = HighScore.register table total time status date diff (fname $ gplayer fact) - ourVictims theirVictims loots + ourVictims theirVictims + (fhiCondPoly $ gplayer fact) return $! if worthMentioning then showScore rScore else mempty getLeaderUI :: MonadClientUI m => m ActorId @@ -312,7 +329,7 @@ return (bname b, hpIndicator) Just (TEnemyPos _ lid p _) -> do let hotText = if lid == lidV - then "hot spot" <+> (T.pack . show) p + then "hot spot" <+> tshow p else "a hot spot on level" <+> tshow (abs $ fromEnum lid) return (hotText, Nothing) Just (TPoint lid p) -> do @@ -321,15 +338,15 @@ then do bag <- getsState $ getCBag (CFloor lid p) case EM.assocs bag of - [] -> return $! "exact spot" <+> (T.pack . show) p + [] -> return $! "exact spot" <+> tshow p [(iid, kit@(k, _))] -> do localTime <- getsState $ getLocalTime lid itemToF <- itemToFullClient - let (name, stats) = partItem (CFloor lid p) lid localTime (itemToF iid kit) + let (_, name, stats) = partItem CGround lid localTime (itemToF iid kit) return $! makePhrase $ if k == 1 then [name, stats] -- "a sword" too wordy else [MU.CarWs k name, stats] - _ -> return $! "many items at" <+> (T.pack . show) p + _ -> return $! "many items at" <+> tshow p else return $! "an exact spot on level" <+> tshow (abs $ fromEnum lid) return (pointedText, Nothing) Just TVector{} -> @@ -338,9 +355,9 @@ Just aid -> do tgtPos <- aidTgtToPos aid lidV target let invalidMsg = "an invalid relative shift" - validMsg p = "shift to" <+> (T.pack . show) p + validMsg p = "shift to" <+> tshow p return (maybe invalidMsg validMsg tgtPos, Nothing) - Nothing -> return ("cursor location", Nothing) + Nothing -> return ("crosshair location", Nothing) targetDescLeader :: MonadClientUI m => ActorId -> m (Text, Maybe Text) targetDescLeader leader = do diff --git a/Game/LambdaHack/Client/UI/MsgClient.hs b/Game/LambdaHack/Client/UI/MsgClient.hs --- a/Game/LambdaHack/Client/UI/MsgClient.hs +++ b/Game/LambdaHack/Client/UI/MsgClient.hs @@ -1,15 +1,14 @@ -- | Client monad for interacting with a human through UI. module Game.LambdaHack.Client.UI.MsgClient ( msgAdd, msgReset, recordHistory - , SlideOrCmd, failWith, failSlides, failSer + , SlideOrCmd, failWith, failSlides, failSer, failMsg , lookAt, itemOverlay ) where -import Control.Arrow (first) +import Control.Applicative import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM -import qualified Data.IntMap.Strict as IM import Data.Maybe import Data.Monoid import Data.Text (Text) @@ -62,7 +61,8 @@ failWith :: MonadClientUI m => Msg -> m (SlideOrCmd a) failWith msg = do stopPlayBack - assert (not $ T.null msg) $ fmap Left $ promptToSlideshow msg + let starMsg = "*" <> msg <> "*" + assert (not $ T.null msg) $ Left <$> promptToSlideshow starMsg failSlides :: MonadClientUI m => Slideshow -> m (SlideOrCmd a) failSlides slides = do @@ -72,6 +72,12 @@ failSer :: MonadClientUI m => ReqFailure -> m (SlideOrCmd a) failSer = failWith . showReqFailure +failMsg :: MonadClientUI m => Msg -> m Slideshow +failMsg msg = do + stopPlayBack + let starMsg = "*" <> msg <> "*" + assert (not $ T.null msg) $ promptToSlideshow starMsg + -- | Produces a textual description of the terrain and items at an already -- explored position. Mute for unknown positions. -- The detailed variant is for use in the targeting mode. @@ -86,23 +92,24 @@ lookAt detailed tilePrefix canSee pos aid msg = do cops@Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops itemToF <- itemToFullClient - lidV <- viewedLevel + b <- getsState $ getActorBody aid + stgtMode <- getsClient stgtMode + let lidV = maybe (blid b) tgtLevelId stgtMode lvl <- getLevel lidV localTime <- getsState $ getLocalTime lidV - b <- getsState $ getActorBody aid subject <- partAidLeader aid is <- getsState $ getCBag $ CFloor lidV pos let verb = MU.Text $ if pos == bpos b then "stand on" else if canSee then "notice" else "remember" - let nWs (iid, kit@(k, _)) = partItemWs k (CFloor lidV pos) lidV localTime (itemToF iid kit) + let nWs (iid, kit@(k, _)) = partItemWs k CGround lidV localTime (itemToF iid kit) isd = case detailed of _ | EM.size is == 0 -> "" _ | EM.size is <= 2 -> makeSentence [ MU.SubjectVerbSg subject verb , MU.WWandW $ map nWs $ EM.assocs is] - True -> "\n" - _ -> "Items here." +-- disabled together with overlay in doLook True -> "\n" + _ -> makeSentence [MU.Cardinal (EM.size is), "items here"] tile = lvl `at` pos obscured | knownLsecret lvl && tile /= hideTile cops lvl pos = "partially obscured" @@ -121,14 +128,15 @@ -- | Create a list of item names. itemOverlay :: MonadClient m - => Container -> LevelId -> ItemBag -> m Overlay + => CStore -> LevelId -> ItemBag -> m Overlay itemOverlay c lid bag = do localTime <- getsState $ getLocalTime lid itemToF <- itemToFullClient - (letterSlots, numberSlots) <- getsClient sslots - assert (all (`elem` EM.elems letterSlots ++ IM.elems numberSlots) - (EM.keys bag) - `blame` (c, lid, bag, letterSlots, numberSlots)) skip + (itemSlots, organSlots) <- getsClient sslots + let isOrgan = c == COrgan + lSlots = if isOrgan then organSlots else itemSlots + let !_A = assert (all (`elem` EM.elems lSlots) (EM.keys bag) + `blame` (c, lid, bag, lSlots)) () let pr (l, iid) = case EM.lookup iid bag of Nothing -> Nothing @@ -139,7 +147,5 @@ -- symbol = jsymbol $ itemBase itemFull in Just $ makePhrase [ slotLabel l, "-" -- MU.String [symbol] , partItemWs k c lid localTime itemFull ] - <> " " - return $! toOverlay $ mapMaybe pr - $ map (first Left) (EM.assocs letterSlots) - ++ (map (first Right) (IM.assocs numberSlots)) + <> " " + return $! toOverlay $ mapMaybe pr $ EM.assocs lSlots diff --git a/Game/LambdaHack/Client/UI/RunClient.hs b/Game/LambdaHack/Client/UI/RunClient.hs --- a/Game/LambdaHack/Client/UI/RunClient.hs +++ b/Game/LambdaHack/Client/UI/RunClient.hs @@ -11,7 +11,7 @@ -- Some things are never ignored, such as: enemies seen, imporant messages -- heard, solid tiles and actors in the way. module Game.LambdaHack.Client.UI.RunClient - ( continueRun, moveRunAid + ( continueRun ) where import Control.Exception.Assert.Sugar @@ -39,158 +39,110 @@ -- | Continue running in the given direction. continueRun :: MonadClient m - => RunParams -> m (Either Msg (RunParams, RequestAnyAbility)) -continueRun paramOld = - case paramOld of - RunParams{ runMembers = [] - , runStopMsg = Just stopMsg } -> return $ Left stopMsg - RunParams{ runLeader - , runMembers = r : rs - , runDist = 0 - , runStopMsg - , runInitDir = Just dir } -> - if r == runLeader then do - -- Start a many-actor run with distance 1, to prevent changing - -- direction on first turn, if the original direction is blocked. - -- We want our runners to keep formation. - let runDistNew = if null rs then 0 else 1 - continueRun paramOld{runDist = runDistNew, runInitDir = Nothing} - else do - runOutcome <- continueRunDir r 0 (Just dir) - case runOutcome of - Left "" -> do -- hack; means that zeroth step OK - runStopOrCmd <- moveRunAid r dir - let runMembersNew = if isJust runStopMsg then rs else rs ++ [r] - paramNew = paramOld {runMembers = runMembersNew} - case runStopOrCmd of - Left stopMsg -> assert `failure` (paramOld, stopMsg) - Right runCmd -> do - s <- getState - modifyClient $ updateLeader r s - return $ Right (paramNew, runCmd) - Left runStopMsgCurrent -> do - let runStopMsgNew = fromMaybe runStopMsgCurrent runStopMsg - paramNew = paramOld { runMembers = rs - , runStopMsg = Just runStopMsgNew } - continueRun paramNew - _ -> assert `failure` (paramOld, runOutcome) - RunParams{ runLeader - , runMembers = r : rs - , runDist - , runStopMsg - , runInitDir = Nothing } -> do - let runDistNew = if r == runLeader then runDist + 1 else runDist - mdirOrRunStopMsgCurrent <- continueRunDir r runDistNew Nothing + => LevelId -> RunParams + -> m (Either Msg RequestAnyAbility) +continueRun arena paramOld = case paramOld of + RunParams{ runMembers = [] + , runStopMsg = Just stopMsg } -> return $ Left stopMsg + RunParams{ runMembers = [] + , runStopMsg = Nothing } -> + return $ Left "selected actors no longer there" + RunParams{ runLeader + , runMembers = r : rs + , runInitial + , runStopMsg } -> do + -- If runInitial and r == runLeader, it means the leader moves + -- again, after all other members, in step 0, + -- so we call continueRunDir with True to change direction once + -- and then unset runInitial. + let runInitialNew = runInitial && r /= runLeader + paramIni = paramOld {runInitial = runInitialNew} + onLevel <- getsState $ memActor r arena + onLevelLeader <- getsState $ memActor runLeader arena + if not onLevel then do + let paramNew = paramIni {runMembers = rs } + continueRun arena paramNew + else if not onLevelLeader then do + let paramNew = paramIni {runLeader = r} + continueRun arena paramNew + else do + mdirOrRunStopMsgCurrent <- continueRunDir paramOld let runStopMsgCurrent = either Just (const Nothing) mdirOrRunStopMsgCurrent runStopMsgNew = runStopMsg `mplus` runStopMsgCurrent -- We check @runStopMsgNew@, because even if the current actor -- runs OK, we want to stop soon if some others had to stop. runMembersNew = if isJust runStopMsgNew then rs else rs ++ [r] - paramNew = paramOld { runMembers = runMembersNew - , runDist = runDistNew + paramNew = paramIni { runMembers = runMembersNew , runStopMsg = runStopMsgNew } case mdirOrRunStopMsgCurrent of - Left _ -> continueRun paramNew -- run all undisturbed; only one time + Left _ -> continueRun arena paramNew + -- run all others undisturbed; one time Right dir -> do s <- getState modifyClient $ updateLeader r s - return $ Right (paramNew, RequestAnyAbility $ ReqMove dir) + modifyClient $ \cli -> cli {srunning = Just paramNew} + return $ Right $ RequestAnyAbility $ ReqMove dir -- The potential invisible actor is hit. War is started without asking. - _ -> assert `failure` paramOld --- | Actor moves or searches or alters. No visible actor at the position. -moveRunAid :: MonadClient m - => ActorId -> Vector -> m (Either Msg RequestAnyAbility) -moveRunAid source dir = do - cops@Kind.COps{cotile} <- getsState scops - sb <- getsState $ getActorBody source - let lid = blid sb - lvl <- getLevel lid - let spos = bpos sb -- source position - tpos = spos `shift` dir -- target position - t = lvl `at` tpos - runStopOrCmd = - -- Movement requires full access. - if accessible cops lvl spos tpos then - -- The potential invisible actor is hit. War started without asking. - Right $ RequestAnyAbility $ ReqMove dir - -- No access, so search and/or alter the tile. Non-walkability is - -- not implied by the lack of access. - else if not (Tile.isWalkable cotile t) - && (not (knownLsecret lvl) - || (isSecretPos lvl tpos -- possible secrets here - && (Tile.isSuspect cotile t -- not yet searched - || Tile.hideAs cotile t /= t)) -- search again - || Tile.isOpenable cotile t - || Tile.isClosable cotile t - || Tile.isChangeable cotile t) then - if EM.member tpos $ lfloor lvl then - Left $ showReqFailure AlterBlockItem - else - Right $ RequestAnyAbility $ ReqAlter tpos Nothing - -- We don't use MoveSer, because we don't hit invisible actors. - -- The potential invisible actor, e.g., in a wall or in - -- an inaccessible doorway, is made known, taking a turn. - -- If server performed an attack for free - -- on the invisible actor anyway, the player (or AI) - -- would be tempted to repeatedly hit random walls - -- in hopes of killing a monster lurking within. - -- If the action had a cost, misclicks would incur the cost, too. - -- Right now the player may repeatedly alter tiles trying to learn - -- about invisible pass-wall actors, but when an actor detected, - -- it costs a turn and does not harm the invisible actors, - -- so it's not so tempting. - -- Ignore a known boring, not accessible tile. - else Left "never mind" - return $! runStopOrCmd - -- | This function implements the actual logic of running. It checks if we -- have to stop running because something interesting cropped up, -- it ajusts the direction given by the vector if we reached -- a corridor's corner (we never change direction except in corridors) -- and it increments the counter of traversed tiles. +-- +-- Note that while goto-cursor commands ignore items on the way, +-- here we stop wnenever we touch an item. Running is more cautious +-- to compensate that the player cannot specify the end-point of running. +-- It's also more suited to open, already explored terrain. Goto-cursor +-- works better with unknown terrain, e.g., it stops whenever an item +-- is spotted, but then ignores the item, leaving it to the player +-- to mark the item position as a goal of the next goto. continueRunDir :: MonadClient m - => ActorId -> Int -> Maybe Vector -> m (Either Msg Vector) -continueRunDir aid distLast mdir = do - sreport <- getsClient sreport -- TODO: check the message before it goes into history - let boringMsgs = map BS.pack [ "You hear a distant" - , "reveals that the" ] - boring repLine = any (`BS.isInfixOf` repLine) boringMsgs - -- TODO: use a regexp from the UI config instead - msgShown = isJust $ findInReport (not . boring) sreport - if msgShown then return $ Left "message shown" - else do - let maxDistance = 20 - cops@Kind.COps{cotile} <- getsState scops - body <- getsState $ getActorBody aid - let lid = blid body - lvl <- getLevel lid - let posHere = bpos body - posLast = boldpos body - dirLast = posHere `vectorToFrom` posLast - dir = fromMaybe dirLast mdir - posThere = posHere `shift` dir - actorsThere <- getsState $ posToActors posThere lid - let openableLast = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir)) - check - | not $ null actorsThere = return $ Left "actor in the way" - -- don't displace actors, except with leader in step 1 - | distLast >= maxDistance = - return $ Left $ "reached max run distance" <+> tshow maxDistance - | accessibleDir cops lvl posHere dir = - if distLast == 0 - then return $ Left "" -- hack; means that zeroth step OK - else checkAndRun aid dir - | distLast /= 1 = return $ Left "blocked" - -- don't change direction, except in step 1 - | openableLast = return $ Left "blocked by a closed door" - -- the player may prefer to open the door - | otherwise = - -- Assume turning is permitted, because this is the start - -- of the run, so the situation is mostly known to the player - tryTurning aid - check + => RunParams -> m (Either Msg Vector) +continueRunDir params = case params of + RunParams{ runMembers = [] } -> assert `failure` params + RunParams{ runLeader + , runMembers = aid : _ + , runInitial } -> do + sreport <- getsClient sreport -- TODO: check the message before it goes into history + let boringMsgs = map BS.pack [ "You hear a distant" + , "reveals that the" ] + boring repLine = any (`BS.isInfixOf` repLine) boringMsgs + -- TODO: use a regexp from the UI config instead + -- or have symbolic messages and pattern-match + msgShown = isJust $ findInReport (not . boring) sreport + if msgShown then return $ Left "message shown" + else do + cops@Kind.COps{cotile} <- getsState scops + rbody <- getsState $ getActorBody runLeader + let rposHere = bpos rbody + rposLast = boldpos rbody + -- Match run-leader dir, because we want runners to keep formation. + dir = rposHere `vectorToFrom` rposLast + body <- getsState $ getActorBody aid + let lid = blid body + lvl <- getLevel lid + let posHere = bpos body + posThere = posHere `shift` dir + actorsThere <- getsState $ posToActors posThere lid + let openableLast = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir)) + check + | not $ null actorsThere = return $ Left "actor in the way" + -- don't displace actors, except with leader in step 0 + | accessibleDir cops lvl posHere dir = + if runInitial && aid /= runLeader + then return $ Right dir -- zeroth step always OK + else checkAndRun aid dir + | not (runInitial && aid == runLeader) = return $ Left "blocked" + -- don't change direction, except in step 1 and by run-leader + | openableLast = return $ Left "blocked by a closed door" + -- the player may prefer to open the door + | otherwise = + -- Assume turning is permitted, because this is the start + -- of the run, so the situation is mostly known to the player + tryTurning aid + check tryTurning :: MonadClient m => ActorId -> m (Either Msg Vector) @@ -274,7 +226,8 @@ `notElem` map posHasItems rightPsLast check | not $ null actorsThere = return $ Left "actor in the way" - -- Actor in possibly another direction tnat original. + -- Actor in possibly another direction tnan original. + -- (e.g., called from @tryTurning@). | terrainChangeLeft = return $ Left "terrain change on the left" | terrainChangeRight = return $ Left "terrain change on the right" | itemChangeLeft = return $ Left "item change on the left" diff --git a/Game/LambdaHack/Client/UI/StartupFrontendClient.hs b/Game/LambdaHack/Client/UI/StartupFrontendClient.hs --- a/Game/LambdaHack/Client/UI/StartupFrontendClient.hs +++ b/Game/LambdaHack/Client/UI/StartupFrontendClient.hs @@ -19,20 +19,22 @@ import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.State --- | Wire together game content, the main loop of game clients, +-- | Wire together game content, the main loops of game clients, -- the main game loop assigned to this frontend (possibly containing -- the server loop, if the whole game runs in one process), -- UI config and the definitions of game commands. srtFrontend :: (DebugModeCli -> SessionUI -> State -> StateClient -> chanServerUI - -> IO ()) + -> IO ()) -- ^ UI main loop -> (DebugModeCli -> SessionUI -> State -> StateClient -> chanServerAI - -> IO ()) - -> KeyKind -> Kind.COps -> DebugModeCli + -> IO ()) -- ^ AI main loop + -> KeyKind -- ^ key and command content + -> Kind.COps -- ^ game content + -> DebugModeCli -- ^ client debug parameters -> ((FactionId -> chanServerUI -> IO ()) -> (FactionId -> chanServerAI -> IO ()) - -> IO ()) + -> IO ()) -- ^ frontend main loop -> IO () srtFrontend executorUI executorAI copsClient cops sdebugCli exeServer = do diff --git a/Game/LambdaHack/Client/UI/WidgetClient.hs b/Game/LambdaHack/Client/UI/WidgetClient.hs --- a/Game/LambdaHack/Client/UI/WidgetClient.hs +++ b/Game/LambdaHack/Client/UI/WidgetClient.hs @@ -1,21 +1,27 @@ -- | A set of widgets for UI clients. module Game.LambdaHack.Client.UI.WidgetClient - ( displayMore, displayYesNo, displayChoiceUI, displayPush, displayPushIfLid + ( displayMore, displayYesNo, displayChoiceUI, displayPush, describeMainKeys , promptToSlideshow, overlayToSlideshow, overlayToBlankSlideshow , animate, fadeOutOrIn ) where -import Control.Monad +import Control.Applicative import qualified Data.EnumMap.Strict as EM +import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid +import qualified Data.Text as T import Game.LambdaHack.Client.BfsClient import qualified Game.LambdaHack.Client.Key as K import Game.LambdaHack.Client.MonadClient hiding (liftIO) import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.Animation +import Game.LambdaHack.Client.UI.Config +import Game.LambdaHack.Client.UI.Content.KeyKind import Game.LambdaHack.Client.UI.DrawClient +import Game.LambdaHack.Client.UI.HumanCmd +import Game.LambdaHack.Client.UI.KeyBindings import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction @@ -28,8 +34,8 @@ -- | A yes-no confirmation. getYesNo :: MonadClientUI m => SingleFrame -> m Bool getYesNo frame = do - let keys = [ K.KM {key=K.Char 'y', modifier=K.NoModifier} - , K.KM {key=K.Char 'n', modifier=K.NoModifier} + let keys = [ K.toKM K.NoModifier (K.Char 'y') + , K.toKM K.NoModifier (K.Char 'n') , K.escKM ] K.KM {key} <- promptGetKey keys frame @@ -43,7 +49,7 @@ displayMore dm prompt = do slides <- promptToSlideshow $ prompt <+> moreMsg -- Two frames drawn total (unless 'prompt' very long). - getInitConfirms dm [] $ slides <> toSlideshow False [[]] + getInitConfirms dm [] $ slides <> toSlideshow Nothing [[]] -- | Print a yes/no question and return the player's answer. Use black -- and white colours to turn player's attention to the choice. @@ -60,43 +66,87 @@ displayChoiceUI :: MonadClientUI m => Msg -> Overlay -> [K.KM] -> m (Either Slideshow K.KM) displayChoiceUI prompt ov keys = do - (_, ovs) <- fmap slideshow $ overlayToSlideshow (prompt <> ", ESC]") ov - let legalKeys = [K.spaceKM, K.escKM] - ++ keys - loop [] = fmap Left $ promptToSlideshow "never mind" - loop (x : xs) = do - frame <- drawOverlay False ColorFull x - km@K.KM {..} <- promptGetKey legalKeys frame - case key of - K.Esc -> fmap Left $ promptToSlideshow "never mind" - K.Space -> loop xs - _ -> return $ Right km - loop ovs + (_, ovs) <- slideshow <$> overlayToSlideshow (prompt <> ", ESC]") ov + let extraKeys = [K.spaceKM, K.escKM, K.pgupKM, K.pgdnKM] + legalKeys = keys ++ extraKeys + loop frs srf = + case frs of + [] -> Left <$> promptToSlideshow "*never mind*" + x : xs -> do + frame <- drawOverlay False ColorFull x + km@K.KM{..} <- promptGetKey legalKeys frame + case key of + _ | km `elem` keys -> return $ Right km -- km can be PgUp, etc. + K.Esc -> Left <$> promptToSlideshow "*never mind*" + K.PgUp -> case srf of + [] -> loop frs srf + y : ys -> loop (y : frs) ys + K.Space -> case xs of + [] -> Left <$> promptToSlideshow "*never mind*" + _ -> loop xs (x : srf) + _ -> case xs of -- K.PgDn and any other permitted key + [] -> loop frs srf + _ -> loop xs (x : srf) + loop ovs [] -- TODO: if more slides, don't take head, but do as in getInitConfirms, -- but then we have to clear the messages or they get redisplayed -- each time screen is refreshed. -- | Push the frame depicting the current level to the frame queue. -- Only one screenful of the report is shown, the rest is ignored. -displayPush :: MonadClientUI m => m () -displayPush = do - side <- getsClient sside - fact <- getsState $ (EM.! side) . sfactionD - sls <- promptToSlideshow "" +displayPush :: MonadClientUI m => Msg -> m () +displayPush prompt = do + sls <- promptToSlideshow prompt let slide = head . snd $ slideshow sls - underAI = isAIFact fact frame <- drawOverlay False ColorFull slide - -- Visually speed up (by remving all empty frames) the show of the sequence - -- of the move frames if the player is running. - srunning <- getsClient srunning - lastPlay <- getsClient slastPlay - displayFrame (isJust srunning || not (null lastPlay) || underAI) - (Just frame) + displayFrame (Just frame) -displayPushIfLid :: MonadClientUI m => LevelId -> m () -displayPushIfLid lid = do - arena <- getArenaUI - when (arena == lid) displayPush +describeMainKeys :: MonadClientUI m => m Msg +describeMainKeys = do + side <- getsClient sside + fact <- getsState $ (EM.! side) . sfactionD + let underAI = isAIFact fact + stgtMode <- getsClient stgtMode + Binding{brevMap} <- askBinding + Config{configVi, configLaptop} <- askConfig + cursor <- getsClient scursor + let kmLeftButtonPress = + M.findWithDefault (K.toKM K.NoModifier K.LeftButtonPress) + macroLeftButtonPress brevMap + kmEscape = + M.findWithDefault (K.toKM K.NoModifier K.Esc) Cancel brevMap + kmCtrlx = + M.findWithDefault (K.toKM K.Control (K.KP 'x')) GameExit brevMap + kmRightButtonPress = + M.findWithDefault (K.toKM K.NoModifier K.RightButtonPress) + TgtPointerEnemy brevMap + kmReturn = + M.findWithDefault (K.toKM K.NoModifier K.Return) Accept brevMap + moveKeys | configVi = "hjklyubn, " + | configLaptop = "uk8o79jl, " + | otherwise = "" + tgtKind = case cursor of + TEnemy _ True -> "at actor" + TEnemy _ False -> "at enemy" + TEnemyPos _ _ _ True -> "at actor" + TEnemyPos _ _ _ False -> "at enemy" + TPoint{} -> "at position" + TVector{} -> "with a vector" + keys | underAI = "" + | isNothing stgtMode = + "Explore with keypad or keys or mouse: [" + <> moveKeys + <> T.intercalate ", " + (map K.showKM [kmLeftButtonPress, kmCtrlx, kmEscape]) + <> "]" + | otherwise = + "Aim" <+> tgtKind <+> "with keypad or keys or mouse: [" + <> moveKeys + <> T.intercalate ", " + (map K.showKM [kmRightButtonPress, kmReturn, kmEscape]) + <> "]" + report <- getsClient sreport + return $! if nullReport report then keys else "" -- | The prompt is shown after the current message, but not added to history. -- This is useful, e.g., in targeting mode, not to spam history. @@ -114,7 +164,7 @@ Level{lxsize, lysize} <- getLevel lid -- TODO: screen length or viewLevel sreport <- getsClient sreport let msg = splitReport lxsize (prependMsg promptAI (addMsg sreport prompt)) - return $! splitOverlay False (lysize + 1) msg overlay + return $! splitOverlay Nothing (lysize + 1) msg overlay msgPromptAI :: MonadClientUI m => m Msg msgPromptAI = do @@ -123,11 +173,13 @@ let underAI = isAIFact fact return $! if underAI then "[press ESC for Main Menu]" else "" -overlayToBlankSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow -overlayToBlankSlideshow prompt overlay = do +overlayToBlankSlideshow :: MonadClientUI m + => Bool -> Msg -> Overlay -> m Slideshow +overlayToBlankSlideshow startAtTop prompt overlay = do lid <- getArenaUI Level{lysize} <- getLevel lid -- TODO: screen length or viewLevel - return $! splitOverlay True (lysize + 3) (toOverlay [prompt]) overlay + return $! splitOverlay (Just startAtTop) (lysize + 3) + (toOverlay [prompt]) overlay -- TODO: restrict the animation to 'per' before drawing. -- | Render animations on top of the current screen frame. @@ -139,7 +191,7 @@ tgtPos <- leaderTgtToPos cursorPos <- cursorToPos let anyPos = fromMaybe (Point 0 0) cursorPos - pathFromLeader leader = fmap Just $ getCacheBfsAndPath leader anyPos + pathFromLeader leader = Just <$> getCacheBfsAndPath leader anyPos bfsmpath <- maybe (return Nothing) pathFromLeader mleader tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader cursorDesc <- targetDescCursor @@ -147,7 +199,7 @@ let over = renderReport (prependMsg promptAI sreport) topLineOnly = truncateToOverlay over basicFrame <- - draw False ColorFull arena cursorPos tgtPos + draw ColorFull arena cursorPos tgtPos bfsmpath cursorDesc tgtDesc topLineOnly snoAnim <- getsClient $ snoAnim . sdebugCli return $! if fromMaybe False snoAnim @@ -161,4 +213,4 @@ Level{lxsize, lysize} <- getLevel lid animMap <- rndToAction $ fadeout out topRight 2 lxsize lysize animFrs <- animate lid animMap - displayFrames animFrs + mapM_ displayFrame animFrs 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 @@ -2,7 +2,7 @@ -- | AI strategy abilities. module Game.LambdaHack.Common.Ability ( Ability(..), Skills - , zeroSkills, unitSkills, addSkills, maxSkills, scaleSkills + , zeroSkills, unitSkills, addSkills, scaleSkills ) where import Data.Binary @@ -27,7 +27,7 @@ type Skills = EM.EnumMap Ability Int zeroSkills :: Skills -zeroSkills = EM.fromDistinctAscList $ zip [minBound..maxBound] (repeat 0) +zeroSkills = EM.empty unitSkills :: Skills unitSkills = EM.fromDistinctAscList $ zip [minBound..maxBound] (repeat 1) @@ -35,9 +35,6 @@ addSkills :: Skills -> Skills -> Skills addSkills = EM.unionWith (+) -maxSkills :: Skills -> Skills -> Skills -maxSkills = EM.unionWith max - scaleSkills :: Int -> Skills -> Skills scaleSkills n = EM.map (n *) @@ -49,8 +46,8 @@ show AbWait = "wait" show AbMoveItem = "manage items" show AbProject = "fling" - show AbApply = "activate" - show AbTrigger = "trigger tile" + show AbApply = "apply" + show AbTrigger = "trigger floor" instance Binary Ability where put = putWord8 . toEnum . fromEnum 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,4 +1,3 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Actors in the game: heroes, monsters, etc. No operation in this module -- involves the 'State' or 'Action' type. module Game.LambdaHack.Common.Actor @@ -9,10 +8,10 @@ , deltaSerious, deltaMild, xM, minusM, minusTwoM, oneM , bspeed, actorTemplate, timeShiftFromSpeed, braced, waitedLastTurn , actorDying, actorNewBorn, unoccupied - , hpTooLow, calmEnough, calmEnough10, hpEnough, hpEnough10 + , hpTooLow, hpHuge, calmEnough, calmEnough10, hpEnough, hpEnough10 -- * Assorted , ActorDict, smellTimeout, checkAdjacent - , mapActorItems_, ppContainer, ppCStore, verbCStore + , keySelected, ppContainer, ppCStore, ppCStoreIn, verbCStore ) where import Control.Exception.Assert.Sugar @@ -27,6 +26,7 @@ import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Time @@ -39,35 +39,42 @@ -- to the original value from @ActorKind@ over time. E.g., HP. data Actor = Actor { -- The trunk of the actor's body (present also in @borgan@ or @beqp@) - btrunk :: !ItemId + btrunk :: !ItemId + -- Presentation - , bsymbol :: !Char -- ^ individual map symbol - , bname :: !Text -- ^ individual name - , bpronoun :: !Text -- ^ individual pronoun - , bcolor :: !Color.Color -- ^ individual map color + , bsymbol :: !Char -- ^ individual map symbol + , bname :: !Text -- ^ individual name + , bpronoun :: !Text -- ^ individual pronoun + , bcolor :: !Color.Color -- ^ individual map color + -- Resources - , btime :: !Time -- ^ absolute time of next action - , bhp :: !Int64 -- ^ current hit points * 1M - , bhpDelta :: !ResDelta -- ^ HP delta this turn * 1M - , bcalm :: !Int64 -- ^ current calm * 1M - , bcalmDelta :: !ResDelta -- ^ calm delta this turn * 1M + , btime :: !Time -- ^ absolute time of next action + , bhp :: !Int64 -- ^ current hit points * 1M + , bhpDelta :: !ResDelta -- ^ HP delta this turn * 1M + , bcalm :: !Int64 -- ^ current calm * 1M + , bcalmDelta :: !ResDelta -- ^ calm delta this turn * 1M + -- Location - , bpos :: !Point -- ^ current position - , boldpos :: !Point -- ^ previous position - , blid :: !LevelId -- ^ current level - , boldlid :: !LevelId -- ^ previous level - , bfid :: !FactionId -- ^ faction the actor belongs to - , boldfid :: !FactionId -- ^ previous faction of the actor - , btrajectory :: !(Maybe ([Vector], Speed)) -- ^ trajectory the actor must - -- travel and his travel speed + , bpos :: !Point -- ^ current position + , boldpos :: !Point -- ^ previous position + , blid :: !LevelId -- ^ current level + , boldlid :: !LevelId -- ^ previous level + , bfid :: !FactionId -- ^ faction the actor currently belongs to + , bfidImpressed :: !FactionId -- ^ the faction actor is attracted to + , bfidOriginal :: !FactionId -- ^ the original faction of the actor + , btrajectory :: !(Maybe ([Vector], Speed)) + -- ^ trajectory the actor must + -- travel and his travel speed + -- Items - , borgan :: !ItemBag -- ^ organs - , beqp :: !ItemBag -- ^ personal equipment - , binv :: !ItemBag -- ^ personal inventory + , borgan :: !ItemBag -- ^ organs + , beqp :: !ItemBag -- ^ personal equipment + , binv :: !ItemBag -- ^ personal inventory + -- Assorted - , bwait :: !Bool -- ^ is the actor waiting right now? - , bproj :: !Bool -- ^ is a projectile? (shorthand only, - -- this can be deduced from bkind) + , bwait :: !Bool -- ^ is the actor waiting right now? + , bproj :: !Bool -- ^ is a projectile? (shorthand only, + -- this can be deduced from bkind) } deriving (Show, Eq) @@ -98,13 +105,16 @@ -- 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 (AbsDepth n) (AbsDepth depth) numMonsters actorCoeff = - assert (depth > 0) - -- Mimics @castDice@. On level 1, First 2 monsters appear fast. - $ let scaledDepth = 5 * n `div` depth +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 - $ (10 * actorCoeff * (numMonsters - scaledDepth)) - `max` actorCoeff) + ((actorCoeff * (numSpawnedCoeff - scaledDepth)) + `max` 1)) -- | The part of speech describing the actor. partActor :: Actor -> MU.Part @@ -130,7 +140,8 @@ binv = EM.empty borgan = EM.empty bwait = False - boldfid = bfid + bfidImpressed = bfid + bfidOriginal = bfid bhpDelta = ResDelta 0 0 bcalmDelta = ResDelta 0 0 bproj = False @@ -152,43 +163,44 @@ -- | Whether an actor is braced for combat this clip. braced :: Actor -> Bool -braced b = bwait b +braced = bwait -- | The actor waited last turn. waitedLastTurn :: Actor -> Bool -waitedLastTurn b = bwait b +waitedLastTurn = bwait actorDying :: Actor -> Bool -actorDying b = if bproj b - then bhp b < 0 - || maybe True (null . fst) (btrajectory b) - else bhp b <= 0 +actorDying b = bhp b <= 0 + || bproj b && maybe True (null . fst) (btrajectory b) actorNewBorn :: Actor -> Bool actorNewBorn b = boldpos b == Point 0 0 && not (waitedLastTurn b) - && not (btime b < timeTurn) + && btime b >= timeTurn hpTooLow :: Actor -> [ItemFull] -> Bool hpTooLow b activeItems = let maxHP = sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems - in bhp b <= oneM || 5 * bhp b < xM maxHP && bhp b < xM 10 + in bhp b <= oneM || 5 * bhp b < xM maxHP && bhp b <= xM 10 +hpHuge :: Actor -> Bool +hpHuge b = bhp b > xM 30 + calmEnough :: Actor -> [ItemFull] -> Bool calmEnough b activeItems = let calmMax = max 1 $ sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems in 2 * xM calmMax <= 3 * bcalm b calmEnough10 :: Actor -> [ItemFull] -> Bool -calmEnough10 b activeItems = calmEnough b activeItems && bcalm b >= xM 10 +calmEnough10 b activeItems = calmEnough b activeItems && bcalm b > xM 10 hpEnough :: Actor -> [ItemFull] -> Bool hpEnough b activeItems = let hpMax = max 1 $ sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems - in 2 * xM hpMax <= 3 * bhp b + in xM hpMax <= 3 * bhp b hpEnough10 :: Actor -> [ItemFull] -> Bool -hpEnough10 b activeItems = hpEnough b activeItems && bhp b >= xM 10 +hpEnough10 b activeItems = hpEnough b activeItems && bhp b > xM 10 -- | Checks for the presence of actors in a position. -- Does not check if the tile is walkable. @@ -205,24 +217,26 @@ checkAdjacent :: Actor -> Actor -> Bool checkAdjacent sb tb = blid sb == blid tb && adjacent (bpos sb) (bpos tb) -mapActorItems_ :: Monad m => (ItemId -> ItemQuant -> m a) -> Actor -> m () -mapActorItems_ f Actor{binv, beqp, borgan} = do - let is = EM.assocs beqp ++ EM.assocs binv ++ EM.assocs borgan - mapM_ (uncurry f) is +keySelected :: (ActorId, Actor) -> (Bool, Bool, Char, Color.Color, ActorId) +keySelected (aid, Actor{bsymbol, bcolor, bhp}) = + (bhp > 0, bsymbol /= '@', bsymbol, bcolor, aid) ppContainer :: Container -> Text ppContainer CFloor{} = "nearby" ppContainer CEmbed{} = "embedded nearby" -ppContainer (CActor _ cstore) = ppCStore cstore -ppContainer CTrunk{} = "in our possession" +ppContainer (CActor _ cstore) = ppCStoreIn cstore +ppContainer c@CTrunk{} = assert `failure` c -ppCStore :: CStore -> Text -ppCStore CGround = "on the ground" -ppCStore COrgan = "among organs" -ppCStore CEqp = "in equipment" -ppCStore CInv = "in inventory" -ppCStore CSha = "in shared stash" +ppCStore :: CStore -> (Text, Text) +ppCStore CGround = ("on", "the ground") +ppCStore COrgan = ("among", "organs") +ppCStore CEqp = ("in", "equipment") +ppCStore CInv = ("in", "pack") +ppCStore CSha = ("in", "shared stash") +ppCStoreIn :: CStore -> Text +ppCStoreIn c = let (tIn, t) = ppCStore c in tIn <+> t + verbCStore :: CStore -> Text verbCStore CGround = "drop" verbCStore COrgan = "implant" @@ -252,7 +266,8 @@ put btime put bwait put bfid - put boldfid + put bfidImpressed + put bfidOriginal put bproj get = do btrunk <- get @@ -275,7 +290,8 @@ btime <- get bwait <- get bfid <- get - boldfid <- get + bfidImpressed <- get + bfidOriginal <- get bproj <- get return $! Actor{..} diff --git a/Game/LambdaHack/Common/ActorState.hs b/Game/LambdaHack/Common/ActorState.hs --- a/Game/LambdaHack/Common/ActorState.hs +++ b/Game/LambdaHack/Common/ActorState.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TupleSections #-} -- | Operations on the 'Actor' type that need the 'State' type, -- but not the 'Action' type. -- TODO: Document an export list after it's rewritten according to #17. @@ -6,25 +7,29 @@ , actorAssocsLvl, actorAssocs, actorList , actorRegularAssocsLvl, actorRegularAssocs, actorRegularList , bagAssocs, bagAssocsK, calculateTotal - , mergeItemQuant, sharedAllOwned, sharedAllOwnedFid - , getCBag, getActorBag, getBodyActorBag, getActorAssocs - , nearbyFreePoints, whereTo, getCarriedAssocs + , mergeItemQuant, sharedAllOwnedFid, findIid + , getCBag, getActorBag, getBodyActorBag, mapActorItems_, getActorAssocs + , nearbyFreePoints, whereTo, getCarriedAssocs, getCarriedIidCStore , posToActors, posToActor, getItemBody, memActor, getActorBody , tryFindHeroK, getLocalTime, itemPrice, regenCalmDelta - , actorInAmbient, actorSkills, maxActorSkills, dispEnemy - , fullAssocs, itemToFull, goesIntoInv, eqpOverfull - , storeFromC, lidFromC, aidFromC + , actorInAmbient, actorSkills, dispEnemy + , fullAssocs, itemToFull, goesIntoInv, goesIntoSha, eqpOverfull + , storeFromC, lidFromC, aidFromC, hasCharge + , strongestMelee, isMelee, isMeleeEqp ) where +import Control.Applicative import Control.Exception.Assert.Sugar import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import Data.Int (Int64) import Data.List import Data.Maybe +import qualified Data.Ord as Ord import qualified Game.LambdaHack.Common.Ability as Ability 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.ItemStrongest @@ -86,8 +91,8 @@ getItemBody :: ItemId -> State -> Item getItemBody iid s = - fromMaybe (assert `failure` "item body not found" - `twith` (iid, s)) $ EM.lookup iid $ sitemD s + let assFail = assert `failure` "item body not found" `twith` (iid, s) + in EM.findWithDefault assFail iid $ sitemD s bagAssocs :: State -> ItemBag -> [(ItemId, Item)] bagAssocs s bag = @@ -133,7 +138,7 @@ -- | Calculate loot's worth for a faction of a given actor. calculateTotal :: Actor -> State -> (ItemBag, Int) calculateTotal body s = - let bag = sharedAllOwned False body s + let bag = sharedAllOwned body s items = map (\(iid, (k, _)) -> (getItemBody iid s, k)) $ EM.assocs bag in (bag, sum $ map itemPrice items) @@ -152,27 +157,33 @@ in EM.unionsWith mergeItemQuant $ map beqp $ if null bs then [body] else bs -sharedOrgan :: Actor -> State -> ItemBag -sharedOrgan body s = - let bs = fidActorNotProjList (bfid body) s - in EM.unionsWith mergeItemQuant - $ map borgan $ if null bs then [body] else bs - -sharedAllOwned :: Bool -> Actor -> State -> ItemBag -sharedAllOwned organs body s = +sharedAllOwned :: Actor -> State -> ItemBag +sharedAllOwned body s = let shaBag = gsha $ sfactionD s EM.! bfid body in EM.unionsWith mergeItemQuant $ [sharedEqp body s, sharedInv body s, shaBag] - ++ [sharedOrgan body s | organs] sharedAllOwnedFid :: Bool -> FactionId -> State -> ItemBag -sharedAllOwnedFid organs fid s = +sharedAllOwnedFid onlyOrgans fid s = let shaBag = gsha $ sfactionD s EM.! fid bs = fidActorNotProjList fid s in EM.unionsWith mergeItemQuant - $ map binv bs ++ map beqp bs ++ [shaBag] - ++ if organs then map borgan bs else [] + $ if onlyOrgans + then map borgan bs + else map binv bs ++ map beqp bs ++ [shaBag] +findIid :: ActorId -> FactionId -> ItemId -> State -> [(Actor, CStore)] +findIid leader fid iid s = + let actors = fidActorNotProjAssocs fid s + itemsOfActor (aid, b) = + let itemsOfCStore store = + let bag = getBodyActorBag b store s + in map (\iid2 -> (iid2, (b, store))) (EM.keys bag) + stores = [CInv, CEqp] ++ [CSha | aid == leader] + in concatMap itemsOfCStore stores + items = concatMap itemsOfActor actors + in map snd $ filter ((== iid) . fst) items + -- | Price an item, taking count into consideration. itemPrice :: (Item, Int) -> Int itemPrice (item, jcount) = @@ -188,8 +199,8 @@ tryFindActor s p = find (p . snd) $ EM.assocs $ sactorD s -tryFindHeroK :: State -> FactionId -> Int -> Maybe (ActorId, Actor) -tryFindHeroK s fact k = +tryFindHeroK :: FactionId -> Int -> State -> Maybe (ActorId, Actor) +tryFindHeroK fact k s = let c | k == 0 = '@' | k > 0 && k < 10 = Char.intToDigit k | otherwise = assert `failure` "no digit" `twith` k @@ -226,13 +237,19 @@ -- | Gets actor body from the current level. Error if not found. getActorBody :: ActorId -> State -> Actor getActorBody aid s = - fromMaybe (assert `failure` "body not found" `twith` (aid, s)) - $ EM.lookup aid $ sactorD s + let assFail = assert `failure` "body not found" `twith` (aid, s) + in EM.findWithDefault assFail aid $ sactorD s getCarriedAssocs :: Actor -> State -> [(ItemId, Item)] getCarriedAssocs b s = - bagAssocs s $ EM.unionsWith (const) [binv b, beqp b, borgan b] + bagAssocs s $ EM.unionsWith const [binv b, beqp b, borgan b] +getCarriedIidCStore :: Actor -> [(ItemId, CStore)] +getCarriedIidCStore b = + let bagCarried (cstore, bag) = map (,cstore) $ EM.keys bag + in concatMap bagCarried + [(CInv, binv b), (CEqp, beqp b), (COrgan, borgan b)] + getCBag :: Container -> State -> ItemBag {-# INLINE getCBag #-} getCBag c s = case c of @@ -241,7 +258,7 @@ CEmbed lid p -> EM.findWithDefault EM.empty p $ lembed (sdungeon s EM.! lid) CActor aid cstore -> getActorBag aid cstore s - CTrunk fid _ _ -> sharedAllOwnedFid False fid s + CTrunk{} -> assert `failure` c getActorBag :: ActorId -> CStore -> State -> ItemBag {-# INLINE getActorBag #-} @@ -260,6 +277,18 @@ CInv -> binv b CSha -> gsha $ sfactionD s EM.! bfid b +mapActorItems_ :: Monad m + => (CStore -> ItemId -> ItemQuant -> m a) -> Actor + -> State + -> m () +mapActorItems_ f b s = do + let notProcessed = [CGround] + sts = [minBound..maxBound] \\ notProcessed + g cstore = do + let bag = getBodyActorBag b cstore s + mapM_ (uncurry $ f cstore) $ EM.assocs bag + mapM_ g sts + getActorAssocs :: ActorId -> CStore -> State -> [(ItemId, Item)] getActorAssocs aid cstore s = bagAssocs s $ getActorBag aid cstore s @@ -286,7 +315,7 @@ -- Worry actor by enemies felt (even if not seen) -- on the level within 3 steps. fact = (EM.! bfid b) . sfactionD $ s - allFoes = actorRegularList (isAtWar fact) (blid b) $ s + allFoes = actorRegularList (isAtWar fact) (blid b) s isHeard body = not (waitedLastTurn body) && chessDist (bpos b) (bpos body) <= 3 noisyFoes = filter isHeard allFoes @@ -305,20 +334,11 @@ let body = getActorBody aid s fact = (EM.! bfid body) . sfactionD $ s factionSkills - | Just aid == mleader = Ability.unitSkills + | Just aid == mleader = Ability.zeroSkills | otherwise = fskillsOther $ gplayer fact itemSkills = sumSkills activeItems in itemSkills `Ability.addSkills` factionSkills -maxActorSkills :: ActorId -> [ItemFull] -> State -> Ability.Skills -maxActorSkills aid activeItems s = - let body = getActorBody aid s - fact = (EM.! bfid body) . sfactionD $ s - factionSkills = Ability.maxSkills Ability.unitSkills - (fskillsOther $ gplayer fact) - itemSkills = sumSkills activeItems - in itemSkills `Ability.addSkills` factionSkills - -- Check whether an actor can displace an enemy. We assume they are adjacent. dispEnemy :: ActorId -> ActorId -> [ItemFull] -> State -> Bool dispEnemy source target activeItems s = @@ -327,14 +347,13 @@ friendlyFid fid = fid == bfid b || isAllied fact fid sup = actorRegularList friendlyFid (blid b) s in any (adjacent (bpos b) . bpos) sup - actorSk = maxActorSkills target activeItems s + actorMaxSk = sumSkills activeItems sb = getActorBody source s tb = getActorBody target s in bproj tb || not (actorDying tb || braced tb - || EM.findWithDefault 0 Ability.AbDisplace actorSk <= 0 - && EM.findWithDefault 0 Ability.AbMove actorSk <= 0 + || EM.findWithDefault 0 Ability.AbMove actorMaxSk <= 0 || hasSupport sb && hasSupport tb) -- solo actors are flexible fullAssocs :: Kind.COps -> DiscoveryKind -> DiscoveryEffect @@ -358,9 +377,17 @@ , itemAE = EM.lookup iid discoEffect } in ItemFull {..} -goesIntoInv :: Item -> Bool -goesIntoInv item = isNothing $ strengthEqpSlot item +-- Non-durable item that hurts doesn't go into equipment by default, +-- but if it is in equipment or among organs, it's used for melee +-- nevertheless, e.g., thorns. +goesIntoInv :: ItemFull -> Bool +goesIntoInv itemFull = not (isJust (strengthEqpSlot $ itemBase itemFull)) +-- TODO: not needed if EqpSlotWeapon stays || isMeleeEqp itemFull) +goesIntoSha :: ItemFull -> Bool +goesIntoSha itemFull = IK.Precious `elem` jfeature (itemBase itemFull) + && goesIntoInv itemFull + eqpOverfull :: Actor -> Int -> Bool eqpOverfull b n = let size = sum $ map fst $ EM.elems $ beqp b in assert (size <= 10 `blame` (b, n, size)) @@ -371,7 +398,7 @@ CFloor{} -> CGround CEmbed{} -> CGround CActor _ cstore -> cstore - CTrunk{} -> CGround + CTrunk{} -> assert `failure` c -- | Determine the dungeon level of the container. If the item is in a shared -- stash, the level depends on which actor asks. @@ -379,10 +406,72 @@ lidFromC (CFloor lid _) _ = lid lidFromC (CEmbed lid _) _ = lid lidFromC (CActor aid _) s = blid $ getActorBody aid s -lidFromC (CTrunk _ lid _) _ = lid +lidFromC c@CTrunk{} _ = assert `failure` c aidFromC :: Container -> Maybe ActorId aidFromC CFloor{} = Nothing aidFromC CEmbed{} = Nothing aidFromC (CActor aid _) = Just aid -aidFromC CTrunk{} = Nothing +aidFromC c@CTrunk{} = assert `failure` c + +hasCharge :: Time -> ItemFull -> Bool +hasCharge localTime itemFull@ItemFull{..} = + let it1 = case strengthFromEqpSlot IK.EqpSlotTimeout itemFull of + Nothing -> [] -- if item not IDed, assume no timeout, to ID by use + Just timeout -> + let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout + charging startT = timeShift startT timeoutTurns > localTime + in filter charging itemTimer + len = length it1 + in len < itemK + +strMelee :: Bool -> Time -> ItemFull -> Maybe Int +strMelee effectBonus localTime itemFull = + let durable = IK.Durable `elem` jfeature (itemBase itemFull) + recharged = hasCharge localTime itemFull + -- We assume extra weapon effects are useful and so such + -- weapons are preferred over weapons with no effects. + -- If the player doesn't like a particular weapon's extra effect, + -- he has to manage this manually. + p (IK.Hurt d) = [Dice.meanDice d] + p (IK.Burn d) = [Dice.meanDice d] + p IK.NoEffect{} = [] + p IK.OnSmash{} = [] + -- Hackish extra bonus to force Summon as first effect used + -- before Calm of enemy is depleted. + p (IK.Recharging IK.Summon{}) = [999 | recharged && effectBonus] + -- We assume the weapon is still worth using, even if some effects + -- are charging; in particular, we assume Hurt or Burn are not + -- under Recharging. + p IK.Recharging{} = [100 | recharged && effectBonus] + p IK.Temporary{} = [] + p _ = [100 | effectBonus] + psum = sum (strengthEffect p itemFull) + in if not (isMelee itemFull) || psum == 0 + then Nothing + else Just $ psum + if durable then 1000 else 0 + +strongestMelee :: Bool -> Time -> [(ItemId, ItemFull)] + -> [(Int, (ItemId, ItemFull))] +strongestMelee effectBonus localTime is = + let f = strMelee effectBonus localTime + g (iid, itemFull) = (\v -> (v, (iid, itemFull))) <$> f itemFull + in sortBy (flip $ Ord.comparing fst) $ mapMaybe g is + +isMelee :: ItemFull -> Bool +isMelee itemFull = + let p IK.Hurt{} = True + p IK.Burn{} = True + p _ = False + in case itemDisco itemFull of + Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} -> + any p jeffects + Just ItemDisco{itemKind=IK.ItemKind{IK.ieffects}} -> + any p ieffects + Nothing -> False + +-- Melee weapon so good (durable) that goes into equipment by default. +isMeleeEqp :: ItemFull -> Bool +isMeleeEqp itemFull = + let durable = IK.Durable `elem` jfeature (itemBase itemFull) + in isMelee itemFull && durable 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 @@ -3,22 +3,24 @@ -- | Representation of dice for parameters scaled with current level depth. module Game.LambdaHack.Common.Dice ( -- * Frequency distribution for casting dice scaled with level depth - Dice, diceConst, diceLevel, diceScale, (|*|) + Dice, diceConst, diceLevel, diceMult, (|*|) , d, ds, dl, intToDice , 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 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 Data.Ratio +import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Tuple @@ -68,11 +70,11 @@ -> SimpleDice -> SimpleDice -> SimpleDice liftA2AdditiveName name f fra frb = let frRes = liftA2 f fra frb - nameRes = - if nameFrequency fra == "0" then + nameRes + | nameFrequency fra == "0" = (if name == "+" then "" else name) <+> nameFrequency frb - else if nameFrequency frb == "0" then nameFrequency fra - else nameFrequency fra <+> name <+> nameFrequency frb + | nameFrequency frb == "0" = nameFrequency fra + | otherwise = nameFrequency fra <+> name <+> nameFrequency frb in renameFreq nameRes frRes dieSimple :: Int -> SimpleDice @@ -95,26 +97,29 @@ data Dice = Dice { diceConst :: SimpleDice , diceLevel :: SimpleDice - , diceScale :: Int + , diceMult :: Int } deriving (Read, Eq, Ord, Generic) +-- Read and Show should be inverses in this case. instance Show Dice where show Dice{..} = T.unpack $ - let rawScaled = nameFrequency diceLevel - scaled = if rawScaled == "0" then "" else rawScaled - signAndScaled = case T.uncons scaled of + 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" then nameFrequency diceConst else if nameFrequency diceConst == "0" then scaled - else nameFrequency diceConst <+> signAndScaled) - <+> if diceScale == 1 then "" else "|*|" <+> tshow diceScale + else nameFrequency diceConst <+> signAndMult) + <+> if diceMult == 1 then "" else "|*|" <+> tshow diceMult instance Hashable Dice instance Binary Dice +instance NFData Dice + instance Num Dice where (Dice dc1 dl1 ds1) + (Dice dc2 dl2 ds2) = Dice (scaleFreq ds1 dc1 + scaleFreq ds2 dc2) @@ -145,51 +150,58 @@ negate = affectBothDice negate abs = affectBothDice abs signum = affectBothDice signum - fromInteger n = Dice (fromInteger n) (fromInteger 0) 1 + fromInteger n = Dice (fromInteger n) 0 1 affectBothDice :: (SimpleDice -> SimpleDice) -> Dice -> Dice affectBothDice f (Dice dc1 dl1 ds1) = Dice (f dc1) (f dl1) ds1 +-- | A single simple dice. d :: Int -> Dice -d n = Dice (dieSimple n) (fromInteger 0) 1 +d n = Dice (dieSimple n) 0 1 +-- | Dice scaled with level. ds :: Int -> Dice -ds n = Dice (fromInteger 0) (dieLevelSimple n) 1 +ds n = Dice 0 (dieLevelSimple n) 1 dl :: Int -> Dice dl = ds -- Not exposed to save on documentation. _z :: Int -> Dice -_z n = Dice (zdieSimple n) (fromInteger 0) 1 +_z n = Dice (zdieSimple n) 0 1 _zl :: Int -> Dice -_zl n = Dice (fromInteger 0) (zdieLevelSimple n) 1 +_zl n = Dice 0 (zdieLevelSimple n) 1 intToDice :: Int -> Dice intToDice = fromInteger . fromIntegral +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) -- | Maximal value of dice. The scaled part taken assuming maximum level. --- Assumes the frequencies are not null. maxDice :: Dice -> Int -maxDice Dice{..} = (maxFreq diceConst + maxFreq diceLevel) * diceScale +maxDice Dice{..} = (fromMaybe 0 (maxFreq diceConst) + + fromMaybe 0 (maxFreq diceLevel)) + * diceMult -- | Minimal value of dice. The scaled part ignored. --- Assumes the frequencies are not null. minDice :: Dice -> Int -minDice Dice{..} = minFreq diceConst * diceScale +minDice Dice{..} = fromMaybe 0 (minFreq diceConst) * diceMult --- | Mean value of dice. The scaled part taken assuming average level. +-- | Mean value of dice. The level-dependent part is taken assuming +-- the highest level, because that's where the game is the hardest. -- Assumes the frequencies are not null. -meanDice :: Dice -> Rational -meanDice Dice{..} = meanFreq diceConst * fromIntegral diceScale - + meanFreq diceLevel * fromIntegral diceScale * (1%2) +meanDice :: Dice -> Int +meanDice Dice{..} = (meanFreq diceConst + meanFreq diceLevel) * diceMult reduceDice :: Dice -> Maybe Int -reduceDice de = if minDice de == maxDice de then Just (minDice de) else Nothing +reduceDice de = + let minD = minDice de + in if minD == maxDice de then Just minD else Nothing -- | Dice for rolling a pair of integer parameters pertaining to, -- respectively, the X and Y cartesian 2D coordinates. @@ -209,5 +221,5 @@ minDiceXY (DiceXY x y) = (minDice x, minDice y) -- | Mean value of DiceXY. -meanDiceXY :: DiceXY -> (Rational, Rational) +meanDiceXY :: DiceXY -> (Int, Int) meanDiceXY (DiceXY x y) = (meanDice x, meanDice y) diff --git a/Game/LambdaHack/Common/EffectDescription.hs b/Game/LambdaHack/Common/EffectDescription.hs --- a/Game/LambdaHack/Common/EffectDescription.hs +++ b/Game/LambdaHack/Common/EffectDescription.hs @@ -6,13 +6,11 @@ ) where import Control.Exception.Assert.Sugar -import qualified Control.Monad.State as St import qualified Data.EnumMap.Strict as EM import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg @@ -32,10 +30,10 @@ effectToSuff :: Effect -> Text effectToSuff effect = case effect of - NoEffect t -> t + NoEffect _ -> "" -- printed specially Hurt dice -> wrapInParens (tshow dice) - Burn p | p <= 0 -> assert `failure` effect - Burn p -> wrapInParens (makePhrase [MU.CarWs p "burn"]) + Burn d -> wrapInParens (tshow d + <+> if d > 1 then "burns" else "burn") Explode t -> "of" <+> tshow t <+> "explosion" RefillHP p | p > 0 -> "of limited healing" <+> wrapInParens (affixBonus p) @@ -101,8 +99,8 @@ let grpText = tshow grp hitText = if hit then "smash" else "drop" in "of" <+> hitText <+> grpText -- TMI: <+> ppCStore store - PolyItem store -> "of repurpose" <+> ppCStore store - Identify store -> "of identify starting" <+> ppCStore store + PolyItem -> "of repurpose on the ground" + Identify -> "of identify on the ground" SendFlying tmod -> "of impact" <+> tmodToSuff "" tmod PushActor tmod -> "of pushing" <+> tmodToSuff "" tmod PullActor tmod -> "of pulling" <+> tmodToSuff "" tmod @@ -125,23 +123,24 @@ in if vSuff == "" && tSuff == "" then "" else verb <+> "with" <+> vSuff <+> tSuff -aspectToSuff :: Show a => Aspect a -> (a -> Text) -> Text -aspectToSuff aspect f = - rawAspectToSuff $ St.evalState (aspectTrav aspect $ return . f) () - rawAspectToSuff :: Aspect Text -> Text rawAspectToSuff aspect = case aspect of + Unique -> "" -- marked by capital letters in name Periodic{} -> "" -- printed specially Timeout{} -> "" -- printed specially - AddMaxHP t -> wrapInParens $ t <+> "HP" - AddMaxCalm t -> wrapInParens $ t <+> "Calm" - AddSpeed t -> wrapInParens $ t <+> "speed" - AddSkills p -> wrapInParens $ "+" <+> T.pack (show $ EM.toList p) AddHurtMelee t -> wrapInParens $ t <> "% melee" AddHurtRanged t -> wrapInParens $ t <> "% ranged" AddArmorMelee t -> "[" <> t <> "%]" AddArmorRanged t -> "{" <> t <> "%}" + AddMaxHP t -> wrapInParens $ t <+> "HP" + AddMaxCalm t -> wrapInParens $ t <+> "Calm" + AddSpeed t -> wrapInParens $ t <+> "speed" + AddSkills p -> + let skillToSuff (skill, bonus) = + (if bonus > 0 then "+" else "") + <> tshow bonus <+> tshow skill + in wrapInParens $ T.intercalate " " $ map skillToSuff $ EM.assocs p AddSight t -> wrapInParens $ t <+> "sight" AddSmell t -> wrapInParens $ t <+> "smell" AddLight t -> wrapInParens $ t <+> "light" @@ -159,10 +158,10 @@ Tactic tactics -> "overrides tactics to" <+> tshow tactics effectToSuffix :: Effect -> Text -effectToSuffix effect = effectToSuff effect +effectToSuffix = effectToSuff aspectToSuffix :: Aspect Int -> Text -aspectToSuffix aspect = aspectToSuff aspect affixBonus +aspectToSuffix = rawAspectToSuff . fmap affixBonus affixBonus :: Int -> Text affixBonus p = case compare p 0 of @@ -185,4 +184,4 @@ kindEffectToSuffix = effectToSuffix kindAspectToSuffix :: Aspect Dice.Dice -> Text -kindAspectToSuffix aspect = aspectToSuff aspect affixDice +kindAspectToSuffix = rawAspectToSuff . fmap affixDice diff --git a/Game/LambdaHack/Common/Faction.hs b/Game/LambdaHack/Common/Faction.hs --- a/Game/LambdaHack/Common/Faction.hs +++ b/Game/LambdaHack/Common/Faction.hs @@ -2,13 +2,14 @@ -- | Factions taking part in the game: e.g., two human players controlling -- the hero faction battling the monster and the animal factions. module Game.LambdaHack.Common.Faction - ( FactionId, FactionDict, Faction(..), Diplomacy(..), Outcome(..), Status(..) + ( FactionId, FactionDict, Faction(..), Diplomacy(..), Status(..) , Target(..) , isHorrorFact - , canMoveFact, noRunWithMulti, isAIFact, autoDungeonLevel, automatePlayer + , noRunWithMulti, isAIFact, autoDungeonLevel, automatePlayer , isAtWar, isAllied , difficultyBound, difficultyDefault, difficultyCoeff #ifdef EXPOSE_INTERNAL + -- * Internal operations , Dipl #endif ) where @@ -43,7 +44,7 @@ , gsha :: !ItemBag -- ^ faction's shared inventory , gvictims :: !(EM.EnumMap (Kind.Id ItemKind) Int) -- ^ members killed } - deriving (Show, Eq) + deriving (Show, Eq, Ord) -- | Diplomacy states. Higher overwrite lower in case of assymetric content. data Diplomacy = @@ -55,16 +56,6 @@ type Dipl = EM.EnumMap FactionId Diplomacy --- | Outcome of a game. -data Outcome = - Killed -- ^ the faction was eliminated - | Defeated -- ^ the faction lost the game in another way - | Camping -- ^ game is supended - | Conquer -- ^ the player won by eliminating all rivals - | Escape -- ^ the player escaped the dungeon alive - | Restart -- ^ game is restarted - deriving (Show, Eq, Ord, Enum) - -- | Current game status. data Status = Status { stOutcome :: !Outcome -- ^ current game outcome @@ -82,7 +73,7 @@ -- ^ last seen position of the targeted actor | TPoint !LevelId !Point -- ^ target a concrete spot | TVector !Vector -- ^ target position relative to actor - deriving (Show, Eq) + deriving (Show, Eq, Ord) -- | Tell whether the faction consists of summoned horrors only. -- @@ -95,13 +86,6 @@ isHorrorFact :: Faction -> Bool isHorrorFact fact = fgroup (gplayer fact) == "horror" -canMoveFact :: Faction -> Bool -> Bool -canMoveFact fact isLeader = - let skillsOther = fskillsOther $ gplayer fact - in if isLeader - then True - else EM.findWithDefault 0 Ability.AbMove skillsOther > 0 - -- A faction where other actors move at once or where some of leader change -- is automatic can't run with multiple actors at once. That would be -- overpowered or too complex to keep correct. @@ -113,7 +97,7 @@ noRunWithMulti :: Faction -> Bool noRunWithMulti fact = let skillsOther = fskillsOther $ gplayer fact - in EM.findWithDefault 0 Ability.AbMove skillsOther > 0 + in EM.findWithDefault 0 Ability.AbMove skillsOther >= 0 || case fleaderMode (gplayer fact) of LeaderNull -> True LeaderAI AutoLeader{} -> True @@ -179,10 +163,6 @@ return $! Faction{..} instance Binary Diplomacy where - put = putWord8 . toEnum . fromEnum - get = fmap (toEnum . fromEnum) getWord8 - -instance Binary Outcome where put = putWord8 . toEnum . fromEnum get = fmap (toEnum . fromEnum) getWord8 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 @@ -88,7 +88,7 @@ Just pathsDataIn -> do let pathsDataOut = dataDir fout bOut <- doesFileExist pathsDataOut - when (not bOut) $ + unless bOut $ Ex.handle (\(_ :: Ex.IOException) -> return ()) (copyFile pathsDataIn pathsDataOut) in mapM_ cpFile files 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 @@ -14,21 +14,24 @@ import Control.Applicative import Control.Arrow (first, second) +import Control.DeepSeq import Control.Exception.Assert.Sugar import Control.Monad import Data.Binary import Data.Foldable (Foldable) +import qualified Data.Foldable as F import Data.Hashable (Hashable) -import Data.Ratio import Data.Text (Text) import Data.Traversable (Traversable) import GHC.Generics (Generic) +import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg -- TODO: do not expose runFrequency -- | The frequency distribution type. Not normalized (operations may -- or may not group the same elements and sum their frequencies). +-- However, elements with zero frequency are removed upon construction. -- -- The @Eq@ instance compares raw representations, not relative, -- normalized frequencies, so operations don't need to preserve @@ -77,6 +80,8 @@ instance Binary a => Binary (Frequency a) +instance NFData a => NFData (Frequency a) + -- | Uniform discrete frequency distribution. uniformFreq :: Text -> [a] -> Frequency a uniformFreq name l = Frequency (map (\x -> (1, x)) l) name @@ -84,9 +89,9 @@ -- | Takes a name and a list of frequencies and items -- into the frequency distribution. toFreq :: Text -> [(Int, a)] -> Frequency a -toFreq = flip Frequency +toFreq name l = Frequency (filter ((> 0 ) . fst) l) name --- | Scale frequecy distribution, multiplying it +-- | Scale frequency distribution, multiplying it -- by a positive integer constant. scaleFreq :: Show a => Int -> Frequency a -> Frequency a scaleFreq n (Frequency xs name) = @@ -100,27 +105,28 @@ -- | Set frequency of an element. setFreq :: Eq a => Frequency a -> a -> Int -> Frequency a setFreq (Frequency xs name) x n = - let f (_, y) | y == x = (n, x) - f my = my - in Frequency (map f xs) name + let xsNew = [(n, x) | n <= 0] ++ filter ((/= x) . snd) xs + in Frequency xsNew name -- | Test if the frequency distribution is empty. nullFreq :: Frequency a -> Bool -nullFreq (Frequency fs _) = all (<= 0) $ map fst fs +{-# INLINE nullFreq #-} +nullFreq (Frequency fs _) = null fs -maxFreq :: (Show a, Ord a) => Frequency a -> a -maxFreq fr@(Frequency xs _) = case filter ((> 0 ) . fst) xs of - [] -> assert `failure` fr - ys -> maximum $ map snd ys +maxFreq :: Ord a => Frequency a -> Maybe a +{-# INLINE maxFreq #-} +maxFreq fr = if nullFreq fr then Nothing else Just $ F.maximum fr -minFreq :: (Show a, Ord a) => Frequency a -> a -minFreq fr@(Frequency xs _) = case filter ((> 0 ) . fst) xs of - [] -> assert `failure` fr - ys -> minimum $ map snd ys +minFreq :: Ord a => Frequency a -> Maybe a +{-# INLINE minFreq #-} +minFreq fr = if nullFreq fr then Nothing else Just $ F.minimum fr -meanFreq :: (Show a, Integral a) => Frequency a -> Rational -meanFreq fr@(Frequency xs _) = case filter ((> 0 ) . fst) xs of +-- | Average value of an @Int@ distribution, rounded up to avoid truncating +-- it in the other code higher up, which would equate 1d0 with 1d1. +meanFreq :: Frequency Int -> Int +{-# INLINE meanFreq #-} +meanFreq fr@(Frequency xs _) = case xs of [] -> assert `failure` fr - ys -> let sumP = sum $ map fst ys - sumX = sum [ fromIntegral p * x | (p, x) <- ys ] - in if sumX == 0 then 0 else fromIntegral sumX % fromIntegral sumP + _ -> let sumX = sum [ p * x | (p, x) <- xs ] + sumP = sum $ map fst xs + in sumX `divUp` sumP 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 @@ -2,8 +2,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | High score table operations. module Game.LambdaHack.Common.HighScore - ( ScoreTable, empty, register, showScore, getRecord, highSlideshow + ( ScoreDict, ScoreTable + , empty, register, showScore, getTable, getRecord, highSlideshow #ifdef EXPOSE_INTERNAL + -- * Internal operations , ScoreRecord #endif ) where @@ -25,6 +27,8 @@ import Game.LambdaHack.Common.Msg 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. @@ -51,6 +55,16 @@ instance Binary ScoreRecord +-- | The list of scores, in decreasing order. +newtype ScoreTable = ScoreTable [ScoreRecord] + deriving (Eq, Binary) + +instance Show ScoreTable where + show _ = "a score table" + +-- | 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 :: (Int, ScoreRecord) -> [Text] showScore (pos, score) = @@ -72,28 +86,24 @@ diff = difficulty score diffText | diff == difficultyDefault = "" | otherwise = "difficulty" <+> tshow diff <> ", " - tturns = makePhrase $ [MU.CarWs turns "turn"] + 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 (assert `failure` (pos, table)) $ listToMaybe $ drop (pred pos) table --- | The list of scores, in decreasing order. -newtype ScoreTable = ScoreTable [ScoreRecord] - deriving (Eq, Binary) - -instance Show ScoreTable where - show _ = "a score table" - -- | Empty score table -empty :: ScoreTable -empty = ScoreTable [] +empty :: ScoreDict +empty = EM.empty -- | Insert a new score into the table, Return new table and the ranking. -- Make sure the table doesn't grow too large. @@ -113,36 +123,29 @@ -> Text -- ^ name of the faction's gplayer -> EM.EnumMap (Kind.Id ItemKind) Int -- ^ allies lost -> EM.EnumMap (Kind.Id ItemKind) Int -- ^ foes killed - -> Bool -- ^ whether the faction fights against spawners + -> HiCondPoly -> (Bool, (ScoreTable, Int)) register table total time status@Status{stOutcome} date difficulty gplayerName - ourVictims theirVictims loots = - let pBase = - if loots - -- Heroes rejoice in loot and mourn their victims. - then fromIntegral total - -- Spawners or skirmishers get no bonus from loot and no malus - -- from loses, but try to kill opponents fast and blodily, - -- or at least hold up for long and incur heavy losses. - else let turnsSpent = timeFitUp time timeTurn - speedup = max 0 $ 1000000 - 100 * turnsSpent - survival = 100 * turnsSpent - in if stOutcome `elem` [Conquer, Escape] - -- Up to 1000 points for quick victory, so up to 10000 turns. - then sqrt $ fromIntegral speedup - -- Up to 1000 points for surviving long, so up to 10000 turns. - else min 1000 - $ sqrt $ fromIntegral survival - pBonus = - if loots - then max 0 (1000 - 100 * sum (EM.elems ourVictims)) - else 1000 + 100 * sum (EM.elems theirVictims) - pSum :: Double - pSum = if stOutcome `elem` [Conquer, Escape] - then pBase + fromIntegral pBonus - else pBase + ourVictims theirVictims hiCondPoly = + let turnsSpent = fromIntegral $ timeFitUp time timeTurn + hiInValue (hi, c) = case hi of + HiConst -> c + HiLoot -> c * fromIntegral total + HiBlitz -> -- Up to 1000000/c turns matter. + sqrt $ max 0 (1000000 + c * turnsSpent) + HiSurvival -> -- Up to 1000000/c turns matter. + sqrt $ max 0 (min 1000000 $ c * turnsSpent) + HiKill -> c * fromIntegral (sum (EM.elems theirVictims)) + HiLoss -> c * fromIntegral (sum (EM.elems ourVictims)) + hiPolynomialValue = sum . map hiInValue + hiSummandValue (hiPoly, outcomes) = + if stOutcome `elem` outcomes + then max 0 (hiPolynomialValue hiPoly) + else 0 + hiCondValue = sum . map hiSummandValue points = (ceiling :: Double -> Int) - $ pSum * 1.5 ^^ (- (difficultyCoeff difficulty)) + $ hiCondValue hiCondPoly + * 1.5 ^^ (- (difficultyCoeff difficulty)) negTime = absoluteTimeNegate time score = ScoreRecord{..} in (points > 0, insertPos score table) @@ -153,7 +156,7 @@ tshowable (ScoreTable table) start height = let zipped = zip [1..] table screenful = take height . drop (start - 1) $ zipped - in (intercalate ["\n"] $ map showScore screenful) ++ [moreMsg] + in intercalate ["\n"] (map showScore screenful) ++ [moreMsg] -- | Produce a couple of renderings of the high scores table. showCloseScores :: Int -> ScoreTable -> Int -> [[Text]] @@ -166,12 +169,13 @@ -- | Generate a slideshow with the current and previous scores. highSlideshow :: ScoreTable -- ^ current score table -> Int -- ^ position of the current score in the table + -> Text -- ^ the name of the game mode -> Slideshow -highSlideshow table pos = +highSlideshow table pos gameModeName = let (_, nlines) = normalLevelBound -- TODO: query terminal size instead height = nlines `div` 3 posStatus = status $ getRecord pos table - (subject, person, msgUnless) = + (efforts, person, msgUnless) = case stOutcome posStatus of Killed | stDepth posStatus <= 1 -> ("your short-lived struggle", MU.Sg3rd, "(no bonus)") @@ -186,17 +190,18 @@ Conquer -> ("your ruthless victory", MU.Sg3rd, if pos <= height - then "among the greatest heroes" + then "among the best" -- "greatest heroes" doesn't fit else "(bonus included)") Escape -> ("your dashing coup", MU.Sg3rd, if pos <= height - then "among the greatest heroes" + then "among the best" else "(bonus included)") Restart -> ("your abortive attempt", MU.Sg3rd, "(no bonus)") + subject = + makePhrase [efforts, "in", MU.Capitalize $ MU.Text gameModeName] msg = makeSentence - [ MU.SubjectVerb person MU.Yes subject "award you" - , MU.Ordinal pos, "place" - , msgUnless ] - in toSlideshow False $ map ([msg, "\n"] ++) $ showCloseScores pos table height + [ MU.SubjectVerb person MU.Yes (MU.Text subject) "award you" + , MU.Ordinal pos, "place", msgUnless ] + in toSlideshow Nothing $ map ([msg, "\n"] ++) $ showCloseScores pos table height 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 @@ -17,6 +17,7 @@ import Data.Hashable (Hashable) import qualified Data.Ix as Ix import Data.Text (Text) +import Data.Traversable (traverse) import GHC.Generics (Generic) import System.Random (mkStdGen) @@ -48,7 +49,7 @@ data ItemAspectEffect = ItemAspectEffect { jaspects :: ![Aspect Int] -- ^ the aspects of the item - , jeffects :: ![Effect] -- ^ the effects when activated + , jeffects :: ![Effect] -- ^ the effects when applied } deriving (Show, Eq, Generic) @@ -108,7 +109,7 @@ -> ItemAspectEffect seedToAspectsEffects (ItemSeed itemSeed) kind ldepth totalDepth = let castD = castDice ldepth totalDepth - rollA = mapM (flip aspectTrav castD) (iaspects kind) + rollA = mapM (traverse castD) (iaspects kind) jaspects = St.evalState rollA (mkStdGen itemSeed) jeffects = ieffects kind in ItemAspectEffect{..} diff --git a/Game/LambdaHack/Common/ItemDescription.hs b/Game/LambdaHack/Common/ItemDescription.hs --- a/Game/LambdaHack/Common/ItemDescription.hs +++ b/Game/LambdaHack/Common/ItemDescription.hs @@ -1,6 +1,6 @@ -- | Descripitons of items. module Game.LambdaHack.Common.ItemDescription - ( partItemN, partItem, partItemWs, partItemAW, partItemWownW + ( partItemN, partItem, partItemWs, partItemAW, partItemMediumAW, partItemWownW , itemDesc, textAllAE, viewItem ) where @@ -10,7 +10,6 @@ import qualified Data.Text as T import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.EffectDescription @@ -25,40 +24,51 @@ -- TODO: remove _lid if still unused after some time -- | The part of speech describing the item parameterized by the number -- of effects/aspects to show.. -partItemN :: Bool -> Int -> Container -> LevelId -> Time -> ItemFull - -> (MU.Part, MU.Part) +partItemN :: Int -> Int -> CStore -> LevelId -> Time -> ItemFull + -> (Bool, MU.Part, MU.Part) partItemN fullInfo n c _lid localTime itemFull = let genericName = jname $ itemBase itemFull in case itemDisco itemFull of Nothing -> let flav = flavourToName $ jflavour $ itemBase itemFull - in (MU.Text $ flav <+> genericName, "") - Just _ -> - let effTs = filter (not . T.null) $ textAllAE fullInfo c itemFull - it1 = case strengthFromEqpSlot IK.EqpSlotTimeout itemFull of - Nothing -> [] + in (False, MU.Text $ flav <+> genericName, "") + Just iDisco -> + let (toutN, it1) = case strengthFromEqpSlot IK.EqpSlotTimeout itemFull of + Nothing -> (0, []) Just timeout -> let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout - f startT = timeShift startT timeoutTurns > localTime - in filter f (itemTimer itemFull) + charging startT = timeShift startT timeoutTurns > localTime + in (timeout, filter charging (itemTimer itemFull)) len = length it1 - timer = if len == 0 - then "" - else if itemK itemFull == 1 && len == 1 - then "(charging)" - else "(" <> tshow len <+> "charging" <> ")" + chargingAdj | toutN == 0 = "temporary" + | otherwise = "charging" + timer | len == 0 = "" + | itemK itemFull == 1 && len == 1 = "(" <> chargingAdj <> ")" + | otherwise = "(" <> tshow len <+> chargingAdj <> ")" + skipRecharging = fullInfo <= 4 && len >= itemK itemFull + effTs = filter (not . T.null) + $ textAllAE fullInfo skipRecharging c itemFull ts = take n effTs - ++ (if length effTs > n then ["(...)"] else []) + ++ ["(...)" | length effTs > n] ++ [timer] - in (MU.Text genericName, MU.Phrase $ map MU.Text ts) + isUnique aspects = IK.Unique `elem` aspects + unique = case iDisco of + ItemDisco{itemAE=Just ItemAspectEffect{jaspects}} -> + isUnique jaspects + ItemDisco{itemKind} -> + isUnique $ IK.iaspects itemKind + capName = if unique + then MU.Capitalize $ MU.Text genericName + else MU.Text genericName + in (unique, capName, MU.Phrase $ map MU.Text ts) -- | The part of speech describing the item. -partItem :: Container -> LevelId -> Time -> ItemFull -> (MU.Part, MU.Part) -partItem = partItemN False 4 +partItem :: CStore -> LevelId -> Time -> ItemFull -> (Bool, MU.Part, MU.Part) +partItem = partItemN 5 4 -textAllAE :: Bool -> Container -> ItemFull -> [Text] -textAllAE fullInfo c ItemFull{itemBase, itemDisco} = - let features | fullInfo = map featureToSuff $ sort $ jfeature itemBase +textAllAE :: Int -> Bool -> CStore -> ItemFull -> [Text] +textAllAE fullInfo skipRecharging cstore ItemFull{itemBase, itemDisco} = + let features | fullInfo >= 9 = map featureToSuff $ sort $ jfeature itemBase | otherwise = [] in case itemDisco of Nothing -> features @@ -69,13 +79,16 @@ timeoutAspect :: IK.Aspect a -> Bool timeoutAspect IK.Timeout{} = True timeoutAspect _ = False + noEffect :: IK.Effect -> Bool + noEffect IK.NoEffect{} = True + noEffect _ = False hurtEffect :: IK.Effect -> Bool hurtEffect (IK.Hurt _) = True + hurtEffect (IK.Burn _) = True hurtEffect _ = False notDetail :: IK.Effect -> Bool - notDetail IK.Explode{} = fullInfo + notDetail IK.Explode{} = fullInfo >= 6 notDetail _ = True - cstore = storeFromC c active = cstore `elem` [CEqp, COrgan] || cstore == CGround && isJust (strengthEqpSlot itemBase) splitAE :: (Num a, Show a, Ord a) @@ -86,13 +99,13 @@ splitAE reduce_a aspects ppA effects ppE = let mperiodic = find periodicAspect aspects mtimeout = find timeoutAspect aspects + mnoEffect = find noEffect effects restAs = sort aspects (hurtEs, restEs) = partition hurtEffect $ sort $ filter notDetail effects - aes = map ppE hurtEs - ++ if active - then map ppA restAs ++ map ppE restEs - else map ppE restEs ++ map ppA restAs + aes = if active + then map ppA restAs ++ map ppE restEs + else map ppE restEs ++ map ppA restAs rechargingTs = T.intercalate (T.singleton ' ') $ filter (not . T.null) $ map ppE $ stripRecharging restEs @@ -101,7 +114,7 @@ $ map ppE $ stripOnSmash restEs durable = IK.Durable `elem` jfeature itemBase periodicOrTimeout = case mperiodic of - _ | T.null rechargingTs -> "" + _ | skipRecharging || T.null rechargingTs -> "" Just IK.Periodic -> case mtimeout of Just (IK.Timeout 0) | not durable -> @@ -118,37 +131,54 @@ _ -> "" onSmash = if T.null onSmashTs then "" else "(on smash:" <+> onSmashTs <> ")" - in [periodicOrTimeout] ++ aes ++ [onSmash | fullInfo] + noEff = case mnoEffect of + Just (IK.NoEffect t) -> [t] + _ -> [] + in noEff ++ if fullInfo >= 5 || fullInfo >= 2 && null noEff + then [periodicOrTimeout] ++ map ppE hurtEs ++ aes + ++ [onSmash | fullInfo >= 7] + else map ppE hurtEs aets = case itemAE of Just ItemAspectEffect{jaspects, jeffects} -> splitAE tshow jaspects aspectToSuffix jeffects effectToSuffix Nothing -> - splitAE (\d -> maybe "?" tshow $ Dice.reduceDice d) + splitAE (maybe "?" tshow . Dice.reduceDice) (IK.iaspects itemKind) kindAspectToSuffix (IK.ieffects itemKind) kindEffectToSuffix in aets ++ features -- TODO: use kit -partItemWs :: Int -> Container -> LevelId -> Time -> ItemFull -> MU.Part +partItemWs :: Int -> CStore -> LevelId -> Time -> ItemFull -> MU.Part partItemWs count c lid localTime itemFull = - let (name, stats) = partItem c lid localTime itemFull - in MU.Phrase [MU.CarWs count name, stats] + let (unique, name, stats) = partItem c lid localTime itemFull + in if unique && count == 1 + then MU.Phrase ["the", name, stats] + else MU.Phrase [MU.CarWs count name, stats] -partItemAW :: Container -> LevelId -> Time -> ItemFull -> MU.Part +partItemAW :: CStore -> LevelId -> Time -> ItemFull -> MU.Part partItemAW c lid localTime itemFull = - let (name, stats) = partItem c lid localTime itemFull - in MU.AW $ MU.Phrase [name, stats] + let (unique, name, stats) = partItemN 4 4 c lid localTime itemFull + in if unique + then MU.Phrase ["the", name, stats] + else MU.AW $ MU.Phrase [name, stats] -partItemWownW :: MU.Part -> Container -> LevelId -> Time -> ItemFull -> MU.Part +partItemMediumAW :: CStore -> LevelId -> Time -> ItemFull -> MU.Part +partItemMediumAW c lid localTime itemFull = + let (unique, name, stats) = partItemN 5 100 c lid localTime itemFull + in if unique + then MU.Phrase ["the", name, stats] + else MU.AW $ MU.Phrase [name, stats] + +partItemWownW :: MU.Part -> CStore -> LevelId -> Time -> ItemFull -> MU.Part partItemWownW partA c lid localTime itemFull = - let (name, stats) = partItem c lid localTime itemFull + let (_, name, stats) = partItemN 4 4 c lid localTime itemFull in MU.WownW partA $ MU.Phrase [name, stats] -itemDesc :: Container -> LevelId -> Time -> ItemFull -> Overlay +itemDesc :: CStore -> LevelId -> Time -> ItemFull -> Overlay itemDesc c lid localTime itemFull = - let (name, stats) = partItemN True 99 c lid localTime itemFull + let (_, name, stats) = partItemN 10 100 c lid localTime itemFull nstats = makePhrase [name, stats] desc = case itemDisco itemFull of Nothing -> "This item is as unremarkable as can be." @@ -157,10 +187,12 @@ (scaledWeight, unitWeight) = if weight > 1000 then (tshow $ fromIntegral weight / (1000 :: Double), "kg") - else (tshow weight, "g") + else if weight > 0 + then (tshow weight, "g") + else ("", "") ln = abs $ fromEnum $ jlid (itemBase itemFull) colorSymbol = uncurry (flip Color.AttrChar) (viewItem $ itemBase itemFull) - f color = Color.AttrChar Color.defAttr color + f = Color.AttrChar Color.defAttr lxsize = fst normalLevelBound + 1 -- TODO blurb = "D" -- dummy 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 @@ -3,7 +3,7 @@ module Game.LambdaHack.Common.ItemStrongest ( -- * Strongest items strengthOnSmash, strengthCreateOrgan, strengthDropOrgan - , strengthToThrow, strengthEqpSlot, strengthFromEqpSlot + , strengthToThrow, strengthEqpSlot, strengthFromEqpSlot, strengthEffect , strongestSlotNoFilter, strongestSlot, sumSlotNoFilter, sumSkills -- * Assorted , totalRange, computeTrajectory, itemTrajectory @@ -12,7 +12,6 @@ import Control.Applicative import Control.Exception.Assert.Sugar -import qualified Control.Monad.State as St import qualified Data.EnumMap.Strict as EM import Data.List import Data.Maybe @@ -35,10 +34,9 @@ concatMap f jaspects Just ItemDisco{itemKind=ItemKind{iaspects}} -> -- Approximation. For some effects lower values are better, - -- so we can't put 999 here (and for summation, this is wrong). - let trav x = St.evalState (aspectTrav x (return . round . Dice.meanDice)) - () - in concatMap f $ map trav iaspects + -- so we just offer the mean of the dice. This is also correct + -- for summation, on average. + concatMap f $ map (fmap Dice.meanDice) iaspects Nothing -> [] strengthAspectMaybe :: Show b => (Aspect Int -> [b]) -> ItemFull -> Maybe b @@ -49,6 +47,7 @@ xs -> assert `failure` (xs, itemFull) strengthEffect :: (Effect -> [b]) -> ItemFull -> [b] +{-# INLINE strengthEffect #-} strengthEffect f itemFull = case itemDisco itemFull of Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} -> @@ -60,31 +59,6 @@ strengthFeature :: (Feature -> [b]) -> Item -> [b] strengthFeature f item = concatMap f (jfeature item) --- Simplification: does not take into account effects inside @Recharging@, --- because @Hurt@, etc., are unlikely to have a timeout. -strengthMelee :: ItemFull -> Maybe Int -strengthMelee itemFull = - let durable = Durable `elem` jfeature (itemBase itemFull) - p (Hurt d) = [floor (Dice.meanDice d)] - p (Burn k) = [k] - p _ = [] - hasExtraEffects = case itemDisco itemFull of - Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} -> - any (\ef -> null $ p ef) jeffects - Just ItemDisco{itemKind=ItemKind{ieffects}} -> - any (\ef -> null $ p ef) ieffects - Nothing -> False - -- We assume extra weapon effects are usually useful and so such - -- weapons are preferred over weapons with the same power, by default. - -- If the player doesn't like a particular weapon's extra effect, - -- he has to manage this manually. - bonusExtraEffects = if hasExtraEffects then 1 else 0 - psum = sum (strengthEffect p itemFull) - in if psum == 0 - then Nothing - else Just $ bonusExtraEffects + psum + if durable then 100 else 0 - --- Called only by the server, so 999 is OK. strengthOnSmash :: ItemFull -> [Effect] strengthOnSmash = let p (OnSmash eff) = [eff] @@ -146,7 +120,7 @@ strengthAddSkills :: Ability.Ability -> ItemFull -> Maybe Int strengthAddSkills ab = - let p (AddSkills a) = [fromMaybe 0 $ EM.lookup ab a] + let p (AddSkills a) = [EM.findWithDefault 0 ab a] p _ = [] in strengthAspectMaybe p @@ -245,11 +219,19 @@ EqpSlotAddLight -> strengthAddLight EqpSlotWeapon -> strengthMelee +strengthMelee :: ItemFull -> Maybe Int +strengthMelee itemFull = + let p (Hurt d) = [Dice.meanDice d] + p (Burn d) = [Dice.meanDice d] + p _ = [] + psum = sum (strengthEffect p itemFull) + in if psum == 0 then Nothing else Just psum + strongestSlotNoFilter :: EqpSlot -> [(ItemId, ItemFull)] -> [(Int, (ItemId, ItemFull))] strongestSlotNoFilter eqpSlot is = let f = strengthFromEqpSlot eqpSlot - g (iid, itemFull) = (\v -> (v, (iid, itemFull))) <$> (f itemFull) + g (iid, itemFull) = (\v -> (v, (iid, itemFull))) <$> f itemFull in sortBy (flip $ Ord.comparing fst) $ mapMaybe g is strongestSlot :: EqpSlot -> [(ItemId, ItemFull)] @@ -262,14 +244,14 @@ in strongestSlotNoFilter eqpSlot slotIs sumSlotNoFilter :: EqpSlot -> [ItemFull] -> Int -sumSlotNoFilter eqpSlot is = assert (eqpSlot /= EqpSlotWeapon) $ -- no 999 +sumSlotNoFilter eqpSlot is = let f = strengthFromEqpSlot eqpSlot g itemFull = (* itemK itemFull) <$> f itemFull in sum $ mapMaybe g is sumSkills :: [ItemFull] -> Ability.Skills sumSkills is = - let g itemFull = (Ability.scaleSkills (itemK itemFull)) + let g itemFull = Ability.scaleSkills (itemK itemFull) <$> strengthAllAddSkills itemFull in foldr Ability.addSkills Ability.zeroSkills $ mapMaybe g is @@ -290,21 +272,21 @@ allRecharging :: [Effect] -> [Effect] allRecharging effs = - let getRechargingEffect :: Effect -> Maybe (Effect) + let getRechargingEffect :: Effect -> Maybe Effect getRechargingEffect e@Recharging{} = Just e getRechargingEffect _ = Nothing in mapMaybe getRechargingEffect effs stripRecharging :: [Effect] -> [Effect] stripRecharging effs = - let getRechargingEffect :: Effect -> Maybe (Effect) + let getRechargingEffect :: Effect -> Maybe Effect getRechargingEffect (Recharging e) = Just e getRechargingEffect _ = Nothing in mapMaybe getRechargingEffect effs stripOnSmash :: [Effect] -> [Effect] stripOnSmash effs = - let getOnSmashEffect :: Effect -> Maybe (Effect) + let getOnSmashEffect :: Effect -> Maybe Effect getOnSmashEffect (OnSmash e) = Just e getOnSmashEffect _ = Nothing in mapMaybe getOnSmashEffect effs 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 @@ -10,7 +10,6 @@ import qualified Data.Ix as Ix import Data.List import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) import qualified Data.Text as T import Game.LambdaHack.Common.ContentDef @@ -61,11 +60,12 @@ kindFreq = let tuples = [ (cgroup, (n, (i, k))) | (i, k) <- EM.assocs kindMap - , (cgroup, n) <- getFreq k, n > 0 ] + , (cgroup, n) <- getFreq k + , n > 0 ] f m (cgroup, nik) = M.insertWith (++) cgroup [nik] m in foldl' f M.empty tuples - okind i = fromMaybe (assert `failure` "no kind" `twith` (i, kindMap)) - $ EM.lookup i kindMap + okind i = let assFail = assert `failure` "no kind" `twith` (i, kindMap) + in EM.findWithDefault assFail i kindMap correct a = not (T.null (getName a)) && all ((> 0) . snd) (getFreq a) singleOffenders = [ (offences, a) | a <- content, @@ -76,14 +76,14 @@ assert (null singleOffenders `blame` "some content items not valid" `twith` singleOffenders) $ assert (null allOffences `blame` "the content set not valid" - `twith` (allOffences, content)) $ + `twith` (allOffences, content)) -- By this point 'content' can be GCd. Ops { okind , ouniqGroup = \cgroup -> - let freq = fromMaybe (assert `failure` "no unique group" - `twith` (cgroup, kindFreq)) - $ M.lookup cgroup kindFreq + let freq = let assFail = assert `failure` "no unique group" + `twith` (cgroup, kindFreq) + in M.findWithDefault assFail cgroup kindFreq in case freq of [(n, (i, _))] | n > 0 -> i l -> assert `failure` "not unique" `twith` (l, cgroup, kindFreq) @@ -100,12 +100,13 @@ frequency [ i | (i, k) <- kindFreq M.! cgroup, p k ] -} _ -> return Nothing - , ofoldrWithKey = \f z -> foldr (\(i, a) -> f i a) z - $ EM.assocs kindMap + , ofoldrWithKey = \f z -> foldr (uncurry f) z $ EM.assocs kindMap , ofoldrGroup = \cgroup f z -> case M.lookup cgroup kindFreq of Just freq -> foldr (\(p, (i, a)) -> f p i a) z freq - _ -> z + _ -> assert `failure` "no group '" <> tshow cgroup + <> "' among content that has groups" + <+> tshow (M.keys kindFreq) , obounds = ( fst $ EM.findMin kindMap , fst $ EM.findMax kindMap ) , ospeedup = Nothing -- define elsewhere 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 @@ -76,7 +76,7 @@ , lsmell :: !SmellMap -- ^ remembered smells on the level , ldesc :: !Text -- ^ level description , lstair :: !([Point], [Point]) - -- ^ destinations of (up, down) stairs + -- ^ positions of (up, down) stairs , lseen :: !Int -- ^ currently remembered clear tiles , lclear :: !Int -- ^ total number of initially clear tiles , ltime :: !Time -- ^ date of the last activity on the level @@ -86,7 +86,7 @@ , litemFreq :: !(Freqs ItemKind) -- ^ frequency of initial items; [] for clients , lsecret :: !Int -- ^ secret tile seed , lhidden :: !Int -- ^ secret tile density - , lescape :: !Bool -- ^ has an IK.Escape tile + , lescape :: ![Point] -- ^ positions of IK.Escape tiles } deriving (Show, Eq) @@ -154,7 +154,8 @@ isSecretPos :: Level -> Point -> Bool isSecretPos lvl (Point x y) = - (lsecret lvl `Bits.rotateR` x `Bits.xor` y + x) `mod` lhidden lvl == 0 + not (lhidden lvl == 0) + && (lsecret lvl `Bits.rotateR` x `Bits.xor` y + x) `mod` lhidden lvl == 0 hideTile :: Kind.COps -> Level -> Point -> Kind.Id TileKind hideTile Kind.COps{cotile} lvl p = 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 @@ -5,12 +5,15 @@ ( -- * Game object identifiers FactionId, LevelId, AbsDepth(..), ActorId -- * Item containers - , Container(..), CStore(..) + , Container(..), CStore(..), ItemDialogMode(..) -- * Assorted , normalLevelBound, divUp, GroupName, toGroupName, Freqs, breturn , serverSaveName, Rarity, validateRarity, Tactic(..) + -- * Backward compatibility + , isRight ) where +import Control.DeepSeq import Control.Monad import Data.Binary import qualified Data.EnumMap.Strict as EM @@ -27,7 +30,7 @@ import qualified Data.Text as T import Data.Traversable (traverse) import GHC.Generics (Generic) -import NLP.Miniutter.English () +import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Common.Point @@ -41,13 +44,14 @@ infixl 7 `divUp` -- | Integer division, rounding up. divUp :: Integral a => a -> a -> a +{-# INLINE divUp #-} divUp n k = (n + k - 1) `div` k -- 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 (Eq, Ord, Read, Hashable, Binary) + deriving (Eq, Ord, Read, Hashable, Binary, Generic) instance IsString (GroupName a) where fromString = GroupName . T.pack @@ -55,6 +59,8 @@ instance Show (GroupName a) where show (GroupName gn) = T.unpack gn +instance NFData (GroupName a) + toGroupName :: Text -> GroupName a toGroupName = GroupName @@ -64,7 +70,7 @@ type Freqs a = [(GroupName a, Int)] -- | Rarity on given depths. -type Rarity = [(Int, Int)] +type Rarity = [(Double, Int)] validateRarity :: Rarity -> [Text] validateRarity rarity = @@ -72,10 +78,10 @@ in [ "rarity not sorted" | sortedRarity /= rarity ] ++ [ "rarity depth thresholds not unique" | nubBy ((==) `on` fst) sortedRarity /= sortedRarity ] - ++ [ "rarity depth not between 1 and 10" + ++ [ "rarity depth not between 0 and 10" | case (sortedRarity, reverse sortedRarity) of ((lowest, _) : _, (highest, _) : _) -> - lowest < 1 || highest > 10 + lowest <= 0 || highest > 10 _ -> False ] -- | @breturn b a = [a | b]@ @@ -105,6 +111,13 @@ instance Hashable CStore +instance NFData CStore + +data ItemDialogMode = MStore CStore | MOwned | MStats + deriving (Show, Read, Eq, Ord, Generic) + +instance NFData ItemDialogMode + -- | A unique identifier of a faction in a game. newtype FactionId = FactionId Int deriving (Show, Eq, Ord, Enum, Binary) @@ -152,6 +165,12 @@ instance Hashable Tactic +-- TODO: remove me when we no longer suppoert GHC 7.6.* +isRight :: Either a b -> Bool +isRight e = case e of + Right{} -> True + Left{} -> False + -- Data.Binary instance (Enum k, Binary k, Binary e) => Binary (EM.EnumMap k e) where @@ -206,3 +225,11 @@ instance (Enum k, Hashable k, Hashable e) => Hashable (EM.EnumMap k e) where {-# INLINEABLE hashWithSalt #-} hashWithSalt s x = hashWithSalt s (EM.toAscList x) + +-- Control.DeepSeq + +instance NFData MU.Part + +instance NFData MU.Person + +instance NFData MU.Polarity 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 @@ -2,7 +2,7 @@ -- player actions. Has no access to the the main action type. module Game.LambdaHack.Common.MonadStateRead ( MonadStateRead(..) - , getLevel, nUI, posOfAid, factionCanEscape, factionLoots + , getLevel, nUI, posOfAid, factionCanEscape, factionLoots, getGameMode ) where import qualified Data.EnumMap.Strict as EM @@ -10,6 +10,7 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction +import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State @@ -36,7 +37,7 @@ factionCanEscape fid = do fact <- getsState $ (EM.! fid) . sfactionD dungeon <- getsState sdungeon - let escape = any lescape $ EM.elems dungeon + let escape = any (not . null . lescape) $ EM.elems dungeon return $! escape && fcanEscape (gplayer fact) -- TODO: "treasure" is hardwired; tie this code with calculateTotal @@ -48,3 +49,9 @@ loots = any hasTreasure $ EM.elems dungeon canEscape <- factionCanEscape fid return $! canEscape && loots + +getGameMode :: MonadStateRead m => m ModeKind +getGameMode = do + Kind.COps{comode=Kind.Ops{okind}} <- getsState scops + t <- getsState sgameModeId + return $! okind t diff --git a/Game/LambdaHack/Common/Msg.hs b/Game/LambdaHack/Common/Msg.hs --- a/Game/LambdaHack/Common/Msg.hs +++ b/Game/LambdaHack/Common/Msg.hs @@ -2,7 +2,7 @@ -- | Game messages displayed on top of the screen for the player to read. module Game.LambdaHack.Common.Msg ( makePhrase, makeSentence - , Msg, (<>), (<+>), tshow, toWidth, moreMsg, yesnoMsg, truncateMsg + , Msg, (<>), (<+>), tshow, toWidth, moreMsg, endMsg, yesnoMsg, truncateMsg , Report, emptyReport, nullReport, singletonReport, addMsg, prependMsg , splitReport, renderReport, findInReport, lastMsgOfReport , History, emptyHistory, lengthHistory, singletonHistory @@ -22,10 +22,10 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Vector.Binary () import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U import qualified NLP.Miniutter.English as MU -import qualified Text.Show.Pretty as Show.Pretty import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Misc @@ -36,9 +36,9 @@ (<+>) :: Text -> Text -> Text (<+>) = (MU.<+>) --- Pretty print and pack the result of @show@. +-- Show and pack the result of @show@. tshow :: Show a => a -> Text -tshow x = T.pack $ Show.Pretty.ppShow x +tshow x = T.pack $ show x toWidth :: Int -> Text -> Text toWidth n x = T.take n (T.justifyLeft n ' ' x) @@ -56,6 +56,10 @@ moreMsg :: Msg moreMsg = "--more-- " +-- | The \"end of screenfuls of text\" mark. +endMsg :: Msg +endMsg = "--end-- " + -- | The confirmation request message. yesnoMsg :: Msg yesnoMsg = "[yn]" @@ -181,8 +185,11 @@ -- | Render history as many lines of text, wrapping if necessary. renderHistory :: History -> Overlay renderHistory (History h) = - let w = fst normalLevelBound + 1 - in toOverlay $ concatMap (splitReportForHistory w) h + let (x, y) = normalLevelBound + screenLength = y + 2 + reportLines = concatMap (splitReportForHistory (x + 1)) $ reverse h + padding = screenLength - length reportLines `mod` screenLength + in toOverlay $ replicate padding "" ++ reportLines splitReportForHistory :: X -> (Time, Report) -> [Text] splitReportForHistory w (time, r) = @@ -206,7 +213,7 @@ type ScreenLine = U.Vector Int32 toScreenLine :: Text -> ScreenLine -toScreenLine t = let f c = AttrChar defAttr c +toScreenLine t = let f = AttrChar defAttr in encodeLine $ map f $ T.unpack t encodeLine :: [AttrChar] -> ScreenLine @@ -229,14 +236,17 @@ toOverlay :: [Text] -> Overlay toOverlay = let lxsize = fst normalLevelBound + 1 -- TODO - in Overlay . map toScreenLine . map (truncateMsg lxsize) + in Overlay . map (toScreenLine . truncateMsg lxsize) -- | Split an overlay into a slideshow in which each overlay, -- prefixed by @msg@ and postfixed by @moreMsg@ except for the last one, -- fits on the screen wrt height (but lines may be too wide). -splitOverlay :: Bool -> Y -> Overlay -> Overlay -> Slideshow +splitOverlay :: Maybe Bool -> Y -> Overlay -> Overlay -> Slideshow splitOverlay onBlank yspace (Overlay msg) (Overlay ls) = let len = length msg + endB = [ toScreenLine + $ endMsg <> "[press PGUP to see previous, ESC to cancel]" + | onBlank == Just False ] in if len >= yspace then -- no space left for @ls@ Slideshow (onBlank, [Overlay $ take (yspace - 1) msg @@ -244,7 +254,7 @@ else let splitO over = let (pre, post) = splitAt (yspace - 1) $ msg ++ over in if null (drop 1 post) -- (don't call @length@ on @ls@) - then [Overlay $ msg ++ over] -- all fits on one screen + then [Overlay $ msg ++ over ++ endB] -- all fits on screen else let rest = splitO post in Overlay (pre ++ [toScreenLine moreMsg]) : rest in Slideshow (onBlank, splitO ls) @@ -252,19 +262,19 @@ -- | A few overlays, displayed one by one upon keypress. -- When displayed, they are trimmed, not wrapped -- and any lines below the lower screen edge are not visible. --- If the boolean flag is set, the overlay is displayed over a blank screen, --- including the bottom lines. -newtype Slideshow = Slideshow {slideshow :: (Bool, [Overlay])} +-- If the first pair element is not @Nothing@, the overlay is displayed +-- over a blank screen, including the bottom lines. The boolean flag +-- then indicates whether to start at the topmost screenful or bottommost. +newtype Slideshow = Slideshow {slideshow :: (Maybe Bool, [Overlay])} deriving (Show, Eq) instance Monoid Slideshow where - mempty = Slideshow (False, []) - mappend (Slideshow (b1, l1)) (Slideshow (b2, l2)) = - Slideshow (b1 || b2, l1 ++ l2) + mempty = Slideshow (Nothing, []) + mappend (Slideshow (b1, l1)) (Slideshow (_, l2)) = Slideshow (b1, l1 ++ l2) -- | Declare the list of raw overlays to be fit for display on the screen. -- In particular, current @Report@ is eiter empty or unimportant -- or contained in the overlays and if any vertical or horizontal -- trimming of the overlays happens, this is intended. -toSlideshow :: Bool -> [[Text]] -> Slideshow +toSlideshow :: Maybe Bool -> [[Text]] -> Slideshow toSlideshow onBlank l = Slideshow (onBlank, map toOverlay l) diff --git a/Game/LambdaHack/Common/Point.hs b/Game/LambdaHack/Common/Point.hs --- a/Game/LambdaHack/Common/Point.hs +++ b/Game/LambdaHack/Common/Point.hs @@ -1,13 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} -- | Basic operations on 2D points represented as linear offsets. module Game.LambdaHack.Common.Point - ( X, Y, Point(..), maxLevelDimExponent + ( X, Y, Point(..), dummyPoint, maxLevelDimExponent , chessDist, euclidDistSq, adjacent, inside, bla, fromTo ) where +import Control.DeepSeq import Control.Exception.Assert.Sugar import Data.Binary import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) import Data.Int (Int32) +import GHC.Generics (Generic) -- | Spacial dimension for points and vectors. type X = Int @@ -22,7 +25,7 @@ { px :: !X , py :: !Y } - deriving (Eq, Ord) + deriving (Read, Eq, Ord, Generic) instance Show Point where show (Point x y) = show (x, y) @@ -31,6 +34,8 @@ put = put . (fromIntegral :: Int -> Int32) . fromEnum get = fmap (toEnum . (fromIntegral :: Int32 -> Int)) get +instance NFData Point + -- This conversion cannot be used for PointArray indexing, -- because it is not contiguous --- we don't know the horizontal -- width of the levels nor of the screen. @@ -39,6 +44,9 @@ fromEnum = fromEnumPoint toEnum = toEnumPoint +dummyPoint :: Point +dummyPoint = Point (-10000) (-10000) + -- | The maximum number of bits for level X and Y dimension (16). -- The value is chosen to support architectures with 32-bit Ints. maxLevelDimExponent :: Int @@ -129,8 +137,8 @@ | z0 <= z1 = [z0..z1] | otherwise = [z0,z0-1..z1] result - | x0 == x1 = map (\ y -> Point x0 y) (fromTo1 y0 y1) - | y0 == y1 = map (\ x -> Point x y0) (fromTo1 x0 x1) + | x0 == x1 = map (Point x0) (fromTo1 y0 y1) + | y0 == y1 = map (`Point` y0) (fromTo1 x0 x1) | otherwise = assert `failure` "diagonal fromTo" `twith` ((x0, y0), (x1, y1)) in result diff --git a/Game/LambdaHack/Common/PointArray.hs b/Game/LambdaHack/Common/PointArray.hs --- a/Game/LambdaHack/Common/PointArray.hs +++ b/Game/LambdaHack/Common/PointArray.hs @@ -2,17 +2,20 @@ module Game.LambdaHack.Common.PointArray ( Array , (!), (//), replicateA, replicateMA, generateA, generateMA, sizeA - , foldlA, ifoldlA, mapA, imapA, mapWithKeyM_A - , minIndexA, minLastIndexA, maxIndexA, maxLastIndexA, forceA + , foldlA, ifoldlA, mapA, imapA, mapWithKeyMA + , safeSetA, unsafeSetA, unsafeUpdateA + , minIndexA, minLastIndexA, minIndexesA, maxIndexA, maxLastIndexA, forceA ) where import Control.Arrow ((***)) import Control.Monad +import Control.Monad.ST.Strict import Data.Binary import Data.Vector.Binary () import qualified Data.Vector.Fusion.Stream as Stream import qualified Data.Vector.Generic as G import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Unboxed.Mutable as VM import Game.LambdaHack.Common.Point @@ -59,6 +62,14 @@ (//) Array{..} l = let v = avector U.// map (pindex axsize *** cnv) l in Array{avector = v, ..} +unsafeUpdateA :: Enum c => Array c -> [(Point, c)] -> Array c +{-# INLINE unsafeUpdateA #-} +unsafeUpdateA Array{..} l = runST $ do + vThawed <- U.unsafeThaw avector + mapM_ (\(p, c) -> VM.write vThawed (pindex axsize p) (cnv c)) l + vFrozen <- U.unsafeFreeze vThawed + return $! Array{avector = vFrozen, ..} + -- | Create an array from a replicated element. replicateA :: Enum c => X -> Y -> c -> Array c {-# INLINE replicateA #-} @@ -117,12 +128,27 @@ let v = U.imap (\n c -> cnv $ f (punindex axsize n) (cnv c)) avector in Array{avector = v, ..} +-- | Set all elements to the given value, in place. +unsafeSetA :: Enum c => c -> Array c -> Array c +{-# INLINE unsafeSetA #-} +unsafeSetA c Array{..} = runST $ do + vThawed <- U.unsafeThaw avector + VM.set vThawed (cnv c) + vFrozen <- U.unsafeFreeze vThawed + return $! Array{avector = vFrozen, ..} + +-- | Set all elements to the given value, in place, if possible. +safeSetA :: Enum c => c -> Array c -> Array c +{-# INLINE safeSetA #-} +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. -mapWithKeyM_A :: Enum c => Monad m +mapWithKeyMA :: Enum c => Monad m => (Point -> c -> m ()) -> Array c -> m () -{-# INLINE mapWithKeyM_A #-} -mapWithKeyM_A f Array{..} = +{-# INLINE mapWithKeyMA #-} +mapWithKeyMA f Array{..} = U.ifoldl' (\a n c -> a >> f (punindex axsize n) (cnv c)) (return ()) avector @@ -143,6 +169,18 @@ $ avector where imin (i, x) (j, y) = i `seq` j `seq` if x >= y then (j, y) else (i, x) + +-- | Yield the point coordinates of all the minimum elements of the array. +-- The array may not be empty. +minIndexesA :: Enum c => Array c -> [Point] +{-# INLINE minIndexesA #-} +minIndexesA Array{..} = + map (punindex axsize) + $ Stream.foldl' imin [] . Stream.indexed . G.stream + $ avector + where + imin acc (i, x) = i `seq` if x == minE then i : acc else acc + minE = cnv $ U.minimum avector -- | Yield the point coordinates of the first maximum element of the array. -- The array may not be empty. 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} -- | Representation of probabilities and random computations. module Game.LambdaHack.Common.Random ( -- * The @Rng@ monad @@ -77,12 +76,13 @@ -- 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 - assert (n >= 0 && n <= depth `blame` "invalid depth for dice rolls" - `twith` (n, depth)) skip + let !_A = assert (n >= 0 && n <= depth + `blame` "invalid depth for dice rolls" + `twith` (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.diceScale dice + * Dice.diceMult dice -- | Cast dice scaled with current level depth and return @True@ -- if the results is greater than 50. diff --git a/Game/LambdaHack/Common/Request.hs b/Game/LambdaHack/Common/Request.hs --- a/Game/LambdaHack/Common/Request.hs +++ b/Game/LambdaHack/Common/Request.hs @@ -9,17 +9,20 @@ , permittedPrecious, permittedProject, permittedApply ) where +import Data.Maybe import Data.Text (Text) import Game.LambdaHack.Atomic 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.Common.Misc import Game.LambdaHack.Common.Msg 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 @@ -58,16 +61,15 @@ -- | 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 -> !(Maybe TK.Feature) -> RequestTimed AbAlter - ReqWait :: RequestTimed AbWait - ReqMoveItem :: !ItemId -> !Int -> !CStore -> !CStore - -> RequestTimed AbMoveItem - ReqProject :: !Point -> !Int -> !ItemId -> !CStore -> RequestTimed AbProject - ReqApply :: !ItemId -> !CStore -> RequestTimed AbApply - ReqTrigger :: !(Maybe TK.Feature) -> RequestTimed AbTrigger + ReqMove :: !Vector -> RequestTimed 'AbMove + ReqMelee :: !ActorId -> !ItemId -> !CStore -> RequestTimed 'AbMelee + ReqDisplace :: !ActorId -> RequestTimed 'AbDisplace + ReqAlter :: !Point -> !(Maybe TK.Feature) -> RequestTimed 'AbAlter + ReqWait :: RequestTimed 'AbWait + ReqMoveItems :: ![(ItemId, Int, CStore, CStore)] -> RequestTimed 'AbMoveItem + ReqProject :: !Point -> !Int -> !ItemId -> !CStore -> RequestTimed 'AbProject + ReqApply :: !ItemId -> !CStore -> RequestTimed 'AbApply + ReqTrigger :: !(Maybe TK.Feature) -> RequestTimed 'AbTrigger deriving instance Show (RequestTimed a) @@ -90,6 +92,7 @@ | ApplyUnskilled | ApplyRead | ApplyOutOfReach + | ApplyCharging | ItemNothing | ItemNotCalm | NotCalmPrecious @@ -97,6 +100,7 @@ | ProjectBlockTerrain | ProjectBlockActor | ProjectUnskilled + | ProjectNotRanged | ProjectFragile | ProjectOutOfReach | TriggerNothing @@ -123,6 +127,7 @@ ApplyUnskilled -> False -- unidentified skill items ApplyRead -> False -- unidentified skill items ApplyOutOfReach -> True + ApplyCharging -> False -- if aspects unknown, charging unknown ItemNothing -> True ItemNotCalm -> False -- unidentified skill items NotCalmPrecious -> False -- unidentified skill items @@ -130,6 +135,7 @@ ProjectBlockTerrain -> True -- adjacent terrain always visible ProjectBlockActor -> True -- adjacent actor always visible ProjectUnskilled -> False -- unidentified skill items + ProjectNotRanged -> False -- unidentified skill items ProjectFragile -> False -- unidentified skill items ProjectOutOfReach -> True TriggerNothing -> True -- terrain underneath always visibl @@ -146,16 +152,17 @@ 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 immoblie foe" + DisplaceImmobile -> "trying to displace an immobile foe" DisplaceSupported -> "trying to displace a supported foe" 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" - ApplyUnskilled -> "unskilled actors cannot read" - ApplyRead -> "to read an item requires activate skill 2" + 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" ItemNothing -> "wasting time on void item manipulation" ItemNotCalm -> "you are too alarmed to sort through the shared stash" NotCalmPrecious -> "you are too alarmed to handle such an exquisite item" @@ -163,13 +170,14 @@ ProjectBlockTerrain -> "aiming obstructed by terrain" ProjectBlockActor -> "aiming blocked by an actor" ProjectUnskilled -> "unskilled actors cannot aim" - ProjectFragile -> "to lob a fragile item requires fling skill 2" + ProjectNotRanged -> "to fling a non-missile requires fling skill 2" + ProjectFragile -> "to lob a fragile 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" NoChangeLvlLeader -> "no manual leader change for your team" --- The item should not be activated nor thrown because it's too delicate +-- 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 calm10 forced itemFull = @@ -185,11 +193,15 @@ permittedProject triggerSyms forced skill itemFull@ItemFull{itemBase} b activeItems = let calm10 = calmEnough10 b activeItems + mhurtRanged = strengthFromEqpSlot IK.EqpSlotAddHurtRanged itemFull in if not forced && skill < 1 then Left ProjectUnskilled else if not forced + && isNothing mhurtRanged + && skill < 2 then Left ProjectNotRanged + else if not forced && IK.Fragile `elem` jfeature itemBase - && skill < 2 then Left ProjectFragile + && skill < 3 then Left ProjectFragile else let legal = permittedPrecious calm10 forced itemFull in case legal of @@ -210,19 +222,22 @@ else jsymbol itemBase `elem` triggerSyms in hasEffects && permittedSlot -permittedApply :: [Char] -> Int -> ItemFull -> Actor -> [ItemFull] +permittedApply :: [Char] -> Time -> Int -> ItemFull -> Actor -> [ItemFull] -> Either ReqFailure Bool -permittedApply triggerSyms skill itemFull@ItemFull{itemBase} b activeItems = +permittedApply triggerSyms localTime skill itemFull@ItemFull{itemBase} + b activeItems = let calm10 = calmEnough10 b activeItems in if skill < 1 then Left ApplyUnskilled - else if jsymbol itemBase == '?' - && skill < 2 then Left ApplyRead - else - let legal = permittedPrecious calm10 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 + else if jsymbol itemBase == '?' && skill < 2 then 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. + else if not $ hasCharge localTime itemFull + then Left ApplyCharging + else let legal = permittedPrecious calm10 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/Save.hs b/Game/LambdaHack/Common/Save.hs --- a/Game/LambdaHack/Common/Save.hs +++ b/Game/LambdaHack/Common/Save.hs @@ -103,7 +103,7 @@ handler e = do let msg = "Restore failed. The error message is:" <+> (T.unwords . T.lines) (tshow e) - delayPrint $ msg + delayPrint msg return Nothing either handler return res 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 @@ -3,7 +3,7 @@ ( -- * Basic game state, local or global State -- * State components - , sdungeon, stotalDepth, sactorD, sitemD, sfactionD, stime, scops, shigh + , sdungeon, stotalDepth, sactorD, sitemD, sfactionD, stime, scops, shigh, sgameModeId -- * State operations , defStateGlobal, emptyState, localFromGlobal , updateDungeon, updateDepth, updateActorD, updateItemD @@ -24,6 +24,8 @@ import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.ItemKind (ItemKind) +import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.TileKind (TileKind) -- | View on game state. "Remembered" fields carry a subset of the info @@ -37,18 +39,20 @@ , _sfactionD :: !FactionDict -- ^ remembered sides still in game , _stime :: !Time -- ^ global game time , _scops :: Kind.COps -- ^ remembered content - , _shigh :: !HighScore.ScoreTable -- ^ high score table + , _shigh :: !HighScore.ScoreDict -- ^ high score table + , _sgameModeId :: !(Kind.Id ModeKind) -- ^ current game mode } deriving (Show, Eq) -- TODO: add a flag 'fresh' and when saving levels, don't save -- and when loading regenerate this level. unknownLevel :: Kind.COps -> AbsDepth -> X -> Y - -> Text -> ([Point], [Point]) -> Int -> Int -> Int -> Bool + -> Text -> ([Point], [Point]) -> Int + -> (Freqs ItemKind) -> Int -> Int -> [Point] -> Level unknownLevel Kind.COps{cotile=Kind.Ops{ouniqGroup}} ldepth lxsize lysize ldesc lstair lclear - lsecret lhidden lescape = + litemFreq lsecret lhidden lescape = let unknownId = ouniqGroup "unknown space" outerId = ouniqGroup "basic outer fence" in Level { ldepth @@ -67,7 +71,7 @@ , lactorCoeff = 0 , lactorFreq = [] , litemNum = 0 - , litemFreq = [] + , litemFreq -- = [] --- TODO: field needed by factionLoots , lsecret , lhidden , lescape @@ -84,10 +88,10 @@ in unknownMap PointArray.// outerUpdate -- | Initial complete global game state. -defStateGlobal :: Dungeon -> AbsDepth - -> FactionDict -> Kind.COps -> HighScore.ScoreTable +defStateGlobal :: Dungeon -> AbsDepth -> FactionDict -> Kind.COps + -> HighScore.ScoreDict -> Kind.Id ModeKind -> State -defStateGlobal _sdungeon _stotalDepth _sfactionD _scops _shigh = +defStateGlobal _sdungeon _stotalDepth _sfactionD _scops _shigh _sgameModeId = State { _sactorD = EM.empty , _sitemD = EM.empty @@ -107,11 +111,14 @@ , _stime = timeZero , _scops = undefined , _shigh = HighScore.empty + , _sgameModeId = toEnum 0 -- the initial value is unused } -- TODO: make lstair secret until discovered; use this later on for -- goUp in targeting mode (land on stairs of on the same location up a level -- if this set of stsirs is unknown). +-- TODO: RNG should be secret, too, but we also want it to be deterministic, +-- to aid in bug replication -- | Local state created by removing secret information from global -- state components. localFromGlobal :: State -> State @@ -120,8 +127,8 @@ { _sdungeon = EM.map (\Level{..} -> unknownLevel _scops ldepth lxsize lysize ldesc lstair lclear - lsecret lhidden lescape) - _sdungeon + litemFreq lsecret lhidden lescape) + _sdungeon , .. } @@ -174,9 +181,12 @@ scops :: State -> Kind.COps scops = _scops -shigh :: State -> HighScore.ScoreTable +shigh :: State -> HighScore.ScoreDict shigh = _shigh +sgameModeId :: State -> Kind.Id ModeKind +sgameModeId = _sgameModeId + instance Binary State where put State{..} = do put _sdungeon @@ -186,6 +196,7 @@ put _sfactionD put _stime put _shigh + put _sgameModeId get = do _sdungeon <- get _stotalDepth <- get @@ -194,5 +205,6 @@ _sfactionD <- get _stime <- get _shigh <- get + _sgameModeId <- get let _scops = undefined -- overwritten by recreated cops return $! State{..} diff --git a/Game/LambdaHack/Common/Tile.hs b/Game/LambdaHack/Common/Tile.hs --- a/Game/LambdaHack/Common/Tile.hs +++ b/Game/LambdaHack/Common/Tile.hs @@ -16,15 +16,18 @@ module Game.LambdaHack.Common.Tile ( SmellTime , kindHasFeature, hasFeature - , isClear, isLit, isWalkable, isPassableKind, isPassable, isDoor, isSuspect + , isClear, isLit, isWalkable + , isPassable, isPassableNoSuspect, isDoor, isSuspect , isExplorable, lookSimilar, speedup , openTo, closeTo, embedItems, causeEffects, revealAs, hideAs , isOpenable, isClosable, isChangeable, isEscape, isStair, ascendTo #ifdef EXPOSE_INTERNAL + -- * Internal operations , TileSpeedup(..), Tab, createTab, accessTab #endif ) where +import Control.Applicative import Control.Exception.Assert.Sugar import qualified Data.Array.Unboxed as A import Data.Maybe @@ -45,13 +48,14 @@ type instance Kind.Speedup TileKind = TileSpeedup data TileSpeedup = TileSpeedup - { isClearTab :: !Tab - , isLitTab :: !Tab - , isWalkableTab :: !Tab - , isPassableTab :: !Tab - , isDoorTab :: !Tab - , isSuspectTab :: !Tab - , isChangeableTab :: !Tab + { isClearTab :: !Tab + , isLitTab :: !Tab + , isWalkableTab :: !Tab + , isPassableTab :: !Tab + , isPassableNoSuspectTab :: !Tab + , isDoorTab :: !Tab + , isSuspectTab :: !Tab + , isChangeableTab :: !Tab } newtype Tab = Tab (A.UArray (Kind.Id TileKind) Bool) @@ -80,16 +84,14 @@ -- Essential for efficiency of "FOV", hence tabulated. isClear :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool {-# INLINE isClear #-} -isClear Kind.Ops{ospeedup = Just TileSpeedup{isClearTab}} = - \k -> accessTab isClearTab k +isClear Kind.Ops{ospeedup = Just TileSpeedup{isClearTab}} = accessTab isClearTab isClear cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile -- | Whether a tile is lit on its own. -- Essential for efficiency of "Perception", hence tabulated. isLit :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool {-# INLINE isLit #-} -isLit Kind.Ops{ospeedup = Just TileSpeedup{isLitTab}} = - \k -> accessTab isLitTab k +isLit Kind.Ops{ospeedup = Just TileSpeedup{isLitTab}} = accessTab isLitTab isLit cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile -- | Whether actors can walk into a tile. @@ -97,7 +99,7 @@ isWalkable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool {-# INLINE isWalkable #-} isWalkable Kind.Ops{ospeedup = Just TileSpeedup{isWalkableTab}} = - \k -> accessTab isWalkableTab k + accessTab isWalkableTab isWalkable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile -- | Whether actors can walk into a tile, perhaps opening a door first, @@ -106,15 +108,25 @@ isPassable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool {-# INLINE isPassable #-} isPassable Kind.Ops{ospeedup = Just TileSpeedup{isPassableTab}} = - \k -> accessTab isPassableTab k + accessTab isPassableTab isPassable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile +-- | Whether actors can walk into a tile, perhaps opening a door first, +-- perhaps a hidden door. +-- Essential for efficiency of pathfinding, hence tabulated. +isPassableNoSuspect :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool +{-# INLINE isPassableNoSuspect #-} +isPassableNoSuspect Kind.Ops{ospeedup = + Just TileSpeedup{isPassableNoSuspectTab}} = + accessTab isPassableNoSuspectTab +isPassableNoSuspect cotile = + assert `failure` "no speedup" `twith` Kind.obounds cotile + -- | Whether a tile is a door, open or closed. -- Essential for efficiency of pathfinding, hence tabulated. isDoor :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool {-# INLINE isDoor #-} -isDoor Kind.Ops{ospeedup = Just TileSpeedup{isDoorTab}} = - \k -> accessTab isDoorTab k +isDoor Kind.Ops{ospeedup = Just TileSpeedup{isDoorTab}} = accessTab isDoorTab isDoor cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile -- | Whether a tile is suspect. @@ -122,7 +134,7 @@ isSuspect :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool {-# INLINE isSuspect #-} isSuspect Kind.Ops{ospeedup = Just TileSpeedup{isSuspectTab}} = - \k -> accessTab isSuspectTab k + accessTab isSuspectTab isSuspect cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile -- | Whether a tile kind (specified by its id) has a ChangeTo feature. @@ -130,7 +142,7 @@ isChangeable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool {-# INLINE isChangeable #-} isChangeable Kind.Ops{ospeedup = Just TileSpeedup{isChangeableTab}} = - \k -> accessTab isChangeableTab k + accessTab isChangeableTab isChangeable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile -- | Whether one can easily explore a tile, possibly finding a treasure @@ -163,7 +175,8 @@ $ kindHasFeature TK.Clear isLitTab = createTab cotile $ not . kindHasFeature TK.Dark isWalkableTab = createTab cotile $ kindHasFeature TK.Walkable - isPassableTab = createTab cotile isPassableKind + isPassableTab = createTab cotile $ isPassableKind True + isPassableNoSuspectTab = createTab cotile $ isPassableKind False isDoorTab = createTab cotile $ \tk -> let getTo TK.OpenTo{} = True getTo TK.CloseTo{} = True @@ -176,12 +189,12 @@ in any getTo $ TK.tfeature tk in TileSpeedup {..} -isPassableKind :: TileKind -> Bool -isPassableKind tk = +isPassableKind :: Bool -> TileKind -> Bool +isPassableKind passSuspect tk = let getTo TK.Walkable = True getTo TK.OpenTo{} = True getTo TK.ChangeTo{} = True -- can change to passable and may have loot - getTo TK.Suspect = True + getTo TK.Suspect | passSuspect = True getTo _ = False in any getTo $ TK.tfeature tk @@ -193,8 +206,8 @@ [] -> return t groups -> do grp <- oneOf groups - fmap (fromMaybe $ assert `failure` grp) - $ opick grp (const True) + (fromMaybe $ assert `failure` grp) + <$> opick grp (const True) closeTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) closeTo Kind.Ops{okind, opick} t = do @@ -204,8 +217,8 @@ [] -> return t groups -> do grp <- oneOf groups - fmap (fromMaybe $ assert `failure` grp) - $ opick grp (const True) + (fromMaybe $ assert `failure` grp) + <$> opick grp (const True) embedItems :: Kind.Ops TileKind -> Kind.Id TileKind -> [GroupName ItemKind] embedItems Kind.Ops{okind} t = @@ -227,8 +240,8 @@ [] -> return t groups -> do grp <- oneOf groups - fmap (fromMaybe $ assert `failure` grp) - $ opick grp (const True) + (fromMaybe $ assert `failure` grp) + <$> opick grp (const True) hideAs :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind hideAs 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 @@ -186,11 +186,10 @@ -- We round down to the nearest multiple of 2M (unless the speed -- is very low), to ensure both turns of flight cover the same distance -- and that the speed matches the distance traveled exactly. - multiple2M = sInMs * if v > 2 * sInMs - then 2 * (v `div` (2 * sInMs)) - else v `div` sInMs - minimumSpeed = if mpMs == minimalSpeed then minimalSpeed else sInMs - in Speed $ max minimumSpeed multiple2M + multiple2M = if v > 2 * sInMs + then 2 * sInMs * (v `div` (2 * sInMs)) + else v + in Speed $ max minimalSpeed multiple2M -- | Calculate maximum range in meters of a projectile from its speed. -- See . @@ -203,4 +202,4 @@ rangeFromSpeedAndLinger :: Speed -> Int -> Int rangeFromSpeedAndLinger speed linger = let range = rangeFromSpeed speed - in linger * range `div` 100 + in linger * range `divUp` 100 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,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} -- | Basic operations on 2D vectors represented in an efficient, -- but not unique, way. module Game.LambdaHack.Common.Vector @@ -9,12 +9,13 @@ , RadianAngle, rotate, towards ) where +import Control.DeepSeq import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Int (Int32) -import Data.Maybe import Data.Text (Text) +import GHC.Generics (Generic) import Game.LambdaHack.Common.Point @@ -25,7 +26,7 @@ { vx :: !X , vy :: !Y } - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, Show, Read, Generic) instance Binary Vector where put = put . (fromIntegral :: Int -> Int32) . fromEnum @@ -35,6 +36,8 @@ fromEnum = fromEnumVector toEnum = toEnumVector +instance NFData Vector + -- | Maximal supported vector X and Y coordinates. maxVectorDim :: Int {-# INLINE maxVectorDim #-} @@ -48,11 +51,9 @@ {-# INLINE toEnumVector #-} toEnumVector n = let (y, x) = n `quotRem` (2 ^ maxLevelDimExponent) - (vx, vy) = if x > maxVectorDim - then (x - 2 ^ maxLevelDimExponent, y + 1) - else if x < - maxVectorDim - then (x + 2 ^ maxLevelDimExponent, y - 1) - else (x, y) + (vx, vy) | x > maxVectorDim = (x - 2 ^ maxLevelDimExponent, y + 1) + | x < - maxVectorDim = (x + 2 ^ maxLevelDimExponent, y - 1) + | otherwise = (x, y) in Vector{..} -- | Tells if a vector has length 1 in the chessboard metric. @@ -88,6 +89,7 @@ -- | Vectors of all unit moves in the chessboard metric, -- clockwise, starting north-west. moves :: [Vector] +{-# NOINLINE moves #-} moves = map (uncurry Vector) [(-1, -1), (0, -1), (1, -1), (1, 0), (1, 1), (0, 1), (-1, 1), (-1, 0)] @@ -97,8 +99,8 @@ compassText :: Vector -> Text compassText v = let m = EM.fromList $ zip moves moveTexts - in fromMaybe (assert `failure` "not a unit vector" - `twith` v) $ EM.lookup v m + assFail = assert `failure` "not a unit vector" `twith` v + in EM.findWithDefault assFail v m -- | Vectors of all cardinal direction unit moves, clockwise, starting north. movesCardinal :: [Vector] @@ -113,9 +115,16 @@ -> Point -- ^ position to find neighbours of -> [Point] vicinity lxsize lysize p = + if inside p (1, 1, lxsize - 2, lysize - 2) + then vicinityUnsafe p + else [ res | dxy <- moves + , let res = shift p dxy + , inside res (0, 0, lxsize - 1, lysize - 1) ] + +vicinityUnsafe :: Point -> [Point] +vicinityUnsafe p = [ res | dxy <- moves - , let res = shift p dxy - , inside res (0, 0, lxsize - 1, lysize - 1) ] + , let res = shift p dxy ] -- | All (4 at most) cardinal direction neighbours of a point within an area. vicinityCardinal :: 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 @@ -85,6 +85,6 @@ -- of a cave with a given name. validateAllCaveKind :: [CaveKind] -> [Text] validateAllCaveKind lk = - if any (\k -> maybe False (> 0) $ lookup "campaign random" $ cfreq k) lk + if any (maybe False (> 0) . lookup "campaign random" . cfreq) lk then [] else ["no cave defined for \"campaign random\""] 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,20 +1,23 @@ -{-# LANGUAGE DeriveFunctor, DeriveGeneric #-} +{-# LANGUAGE DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable #-} -- | The type of kinds of weapons, treasure, organs, blasts and actors. module Game.LambdaHack.Content.ItemKind ( ItemKind(..) , Effect(..), TimerDice(..) , Aspect(..), ThrowMod(..) , Feature(..), EqpSlot(..) - , aspectTrav + , slotName , toVelocity, toLinger, toOrganGameTurn, toOrganActorTurn, toOrganNone , validateSingleItemKind, validateAllItemKind ) where -import qualified Control.Monad.State as St +import Control.DeepSeq import Data.Binary +import Data.Foldable (Foldable) import Data.Hashable (Hashable) +import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T +import Data.Traversable (Traversable) import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU @@ -22,6 +25,7 @@ import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.Msg -- | Item properties that are fixed for a given kind of items. data ItemKind = ItemKind @@ -52,7 +56,7 @@ -- Ordinary effects. NoEffect !Text | Hurt !Dice.Dice - | Burn !Int -- Dice.Dice? generalize to other elements? ignite terrain? + | Burn !Dice.Dice -- TODO: generalize to other elements? ignite terrain? | Explode !(GroupName ItemKind) -- ^ explode, producing this group of blasts | RefillHP !Int @@ -73,8 +77,8 @@ -- the store with the given random timer | DropItem !CStore !(GroupName ItemKind) !Bool -- ^ @DropItem CGround x True@ means stomp on items - | PolyItem !CStore - | Identify !CStore + | PolyItem + | Identify | SendFlying !ThrowMod | PushActor !ThrowMod | PullActor !ThrowMod @@ -89,6 +93,8 @@ -- Periodic activation, unless Durable deriving (Show, Read, Eq, Ord, Generic) +instance NFData Effect + data TimerDice = TimerNone | TimerGameTurn !Dice.Dice @@ -102,14 +108,17 @@ show (TimerActorTurn nDm) = show nDm ++ " " ++ if nDm == 1 then "move" else "moves" +instance NFData TimerDice + -- | Aspects of items. Those that are named @Add*@ are additive -- (starting at 0) for all items wielded by an actor and they affect the actor. data Aspect a = - Periodic -- ^ in equipment, activate as often as @Timeout@ permits + Unique -- ^ at most one copy can ever be generated + | Periodic -- ^ in equipment, apply as often as @Timeout@ permits | Timeout !a -- ^ some effects will be disabled until item recharges | AddHurtMelee !a -- ^ percentage damage bonus in melee - | AddArmorMelee !a -- ^ percentage armor bonus against melee | AddHurtRanged !a -- ^ percentage damage bonus in ranged + | AddArmorMelee !a -- ^ percentage armor bonus against melee | AddArmorRanged !a -- ^ percentage armor bonus against ranged | AddMaxHP !a -- ^ maximal hp | AddMaxCalm !a -- ^ maximal calm @@ -118,7 +127,7 @@ | AddSight !a -- ^ FOV radius, where 1 means a single tile | AddSmell !a -- ^ smell radius, where 1 means a single tile | AddLight !a -- ^ light radius, where 1 means a single tile - deriving (Show, Read, Eq, Ord, Generic, Functor) + deriving (Show, Read, Eq, Ord, Generic, Functor, Foldable, Traversable) -- | Parameters modifying a throw. Not additive and don't start at 0. data ThrowMod = ThrowMod @@ -127,6 +136,8 @@ } deriving (Show, Read, Eq, Ord, Generic) +instance NFData ThrowMod + -- | Features of item. Affect only the item in question, not the actor, -- and so not additive in any sense. data Feature = @@ -155,7 +166,7 @@ | EqpSlotAddSight | EqpSlotAddSmell | EqpSlotAddLight - | EqpSlotWeapon + | EqpSlotWeapon -- ^ a hack exclusively for AI that shares weapons deriving (Show, Eq, Ord, Generic) instance Hashable Effect @@ -182,44 +193,21 @@ instance Binary EqpSlot --- TODO: Traversable? --- | Transform an aspect using a stateful function. -aspectTrav :: Aspect a -> (a -> St.State s b) -> St.State s (Aspect b) -aspectTrav Periodic _ = return Periodic -aspectTrav (Timeout a) f = do - b <- f a - return $! Timeout b -aspectTrav (AddMaxHP a) f = do - b <- f a - return $! AddMaxHP b -aspectTrav (AddMaxCalm a) f = do - b <- f a - return $! AddMaxCalm b -aspectTrav (AddSpeed a) f = do - b <- f a - return $! AddSpeed b -aspectTrav (AddSkills as) _ = return $! AddSkills as -aspectTrav (AddHurtMelee a) f = do - b <- f a - return $! AddHurtMelee b -aspectTrav (AddHurtRanged a) f = do - b <- f a - return $! AddHurtRanged b -aspectTrav (AddArmorMelee a) f = do - b <- f a - return $! AddArmorMelee b -aspectTrav (AddArmorRanged a) f = do - b <- f a - return $! AddArmorRanged b -aspectTrav (AddSight a) f = do - b <- f a - return $! AddSight b -aspectTrav (AddSmell a) f = do - b <- f a - return $! AddSmell b -aspectTrav (AddLight a) f = do - b <- f a - return $! AddLight b +slotName :: EqpSlot -> Text +slotName EqpSlotPeriodic = "periodicity" +slotName EqpSlotTimeout = "timeout" +slotName EqpSlotAddHurtMelee = "to melee damage" +slotName EqpSlotAddArmorMelee = "melee armor" +slotName EqpSlotAddHurtRanged = "to ranged damage" +slotName EqpSlotAddArmorRanged = "ranged armor" +slotName EqpSlotAddMaxHP = "max HP" +slotName EqpSlotAddMaxCalm = "max Calm" +slotName EqpSlotAddSpeed = "speed" +slotName EqpSlotAddSkills{} = "skills" +slotName EqpSlotAddSight = "sight radius" +slotName EqpSlotAddSmell = "smell radius" +slotName EqpSlotAddLight = "light radius" +slotName EqpSlotWeapon = "weapon damage" toVelocity :: Int -> Feature toVelocity n = ToThrow $ ThrowMod n 100 @@ -247,12 +235,12 @@ periodicAspect Periodic = True periodicAspect _ = False ps = filter periodicAspect iaspects - in if length ps > 1 then ["more than one Periodic specification"] else [] + in ["more than one Periodic specification" | length ps > 1] ++ let timeoutAspect :: Aspect a -> Bool timeoutAspect Timeout{} = True timeoutAspect _ = False ts = filter timeoutAspect iaspects - in if length ts > 1 then ["more than one Timeout specification"] else [] + in ["more than one Timeout specification" | length ts > 1] -- TODO: if "treasure" stays wired-in, assure there are some treasure items -- TODO: (spans multiple contents) check that there is at least one item @@ -261,4 +249,20 @@ -- can appear at). -- | Validate all item kinds. validateAllItemKind :: [ItemKind] -> [Text] -validateAllItemKind _ = [] +validateAllItemKind content = + let kindFreq :: S.Set (GroupName ItemKind) -- cf. Kind.kindFreq + kindFreq = let tuples = [ cgroup + | k <- content + , (cgroup, n) <- ifreq k + , n > 0 ] + in S.fromList tuples + missingGroups = [ cgroup + | k <- content + , (cgroup, _) <- ikit k + , S.notMember cgroup kindFreq ] + errorMsg = case missingGroups of + [] -> [] + _ -> ["no groups" <+> tshow missingGroups + <+> "among content that has groups" + <+> tshow (S.elems kindFreq)] + in errorMsg 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 @@ -2,10 +2,12 @@ -- | The type of kinds of game modes. module Game.LambdaHack.Content.ModeKind ( Caves, Roster(..), Player(..), ModeKind(..), LeaderMode(..), AutoLeader(..) + , Outcome(..), HiIndeterminant(..), HiCondPoly, HiSummand, HiPolynomial , validateSingleModeKind, validateAllModeKind ) where import Data.Binary +import qualified Data.EnumMap.Strict as EM import qualified Data.IntMap.Strict as IM import Data.Text (Text) import qualified Data.Text as T @@ -43,6 +45,30 @@ } deriving (Show, Eq) +-- | Outcome of a game. +data Outcome = + Killed -- ^ the faction was eliminated + | Defeated -- ^ the faction lost the game in another way + | Camping -- ^ game is supended + | Conquer -- ^ the player won by eliminating all rivals + | Escape -- ^ the player escaped the dungeon alive + | Restart -- ^ game is restarted + deriving (Show, Eq, Ord, Enum, Bounded, Generic) + +instance Binary Outcome + +data HiIndeterminant = HiConst | HiLoot | HiBlitz | HiSurvival | HiKill | HiLoss + deriving (Show, Eq, Ord, Generic) + +instance Binary HiIndeterminant + +type HiPolynomial = [(HiIndeterminant, Double)] + +type HiSummand = (HiPolynomial, [Outcome]) + +-- | Conditional polynomial representing score calculation for this player. +type HiCondPoly = [HiSummand] + -- | Properties of a particular player. data Player a = Player { fname :: !Text -- ^ name of the player @@ -50,6 +76,7 @@ , fskillsOther :: !Skills -- ^ skills of the other actors , fcanEscape :: !Bool -- ^ the player can escape the dungeon , fneverEmpty :: !Bool -- ^ the faction declared killed if no actors + , fhiCondPoly :: !HiCondPoly -- ^ score polynomial for the player , fhasNumbers :: !Bool -- ^ whether actors have numbers, not symbols , fhasGender :: !Bool -- ^ whether actors have gender , ftactic :: !Tactic -- ^ members behave according to this tactic @@ -59,7 +86,7 @@ , fhasUI :: !Bool -- ^ does the faction have a UI client -- (for control or passive observation) } - deriving (Show, Eq, Generic) + deriving (Show, Eq, Ord, Generic) instance Binary a => Binary (Player a) @@ -68,7 +95,7 @@ LeaderNull -- ^ faction can have no leader, is whole under AI control | LeaderAI AutoLeader -- ^ leader under AI control | LeaderUI AutoLeader -- ^ leader under UI control, assumes @fhasUI@ - deriving (Show, Eq, Generic) + deriving (Show, Eq, Ord, Generic) instance Binary LeaderMode @@ -90,7 +117,7 @@ -- if the flag is @False@, server still does a subset -- of the automatic switching, but the client is permitted to do more } - deriving (Show, Eq, Generic) + deriving (Show, Eq, Ord, Generic) instance Binary AutoLeader @@ -119,7 +146,6 @@ in concatMap (checkDipl "rosterEnemy") rosterEnemy ++ concatMap (checkDipl "rosterAlly") rosterAlly --- Note that @fSkillsOther@ needn't be a subset of @fSkillsLeader@. validateSinglePlayer :: Caves -> Player Dice.Dice -> [Text] validateSinglePlayer caves Player{..} = [ "fname empty:" <+> fname | T.null fname ] @@ -133,6 +159,8 @@ | any (`notElem` IM.keys caves) [Dice.minDice fentryLevel .. Dice.maxDice fentryLevel] ] -- simplification + ++ [ "fskillsOther not negative:" <+> fname + | any (>= 0) $ EM.elems fskillsOther ] -- | Validate all game mode kinds. Currently always valid. validateAllModeKind :: [ModeKind] -> [Text] 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 @@ -52,7 +52,6 @@ , rleadLevelClips :: !Int -- ^ server switches leader level that often , rscoresFile :: !FilePath -- ^ name of the scores file , rsavePrefix :: !String -- ^ name of the savefile prefix - , rsharedStash :: !Bool -- ^ whether shared stashes are available , rnearby :: !Int -- ^ what distance between actors is 'nearby' } 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 @@ -5,6 +5,7 @@ , validateSingleTileKind, validateAllTileKind, actionFeatures ) where +import Control.DeepSeq import Control.Exception.Assert.Sugar import Data.Binary import Data.Hashable @@ -23,6 +24,9 @@ -- | The type of kinds of terrain tiles. See @Tile.hs@ for explanation -- of the absence of a corresponding type @Tile@ that would hold -- particular concrete tiles in the dungeon. +-- Note that tile names (and any other content names) should not be plural +-- (that would lead to "a stairs"), so "road with cobblestones" is fine, +-- but "granite cobblestones" is wrong. data TileKind = TileKind { tsymbol :: !Char -- ^ map symbol , tname :: !Text -- ^ short description @@ -61,6 +65,8 @@ instance Binary Feature instance Hashable Feature + +instance NFData Feature -- TODO: (spans multiple contents) check that all posible solid place -- fences have hidden counterparts. 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 @@ -7,6 +7,7 @@ module Game.LambdaHack.SampleImplementation.SampleMonadClient ( executorCli #ifdef EXPOSE_INTERNAL + -- * Internal operations , CliImplementation #endif ) where @@ -41,7 +42,7 @@ , cliSession :: SessionUI -- ^ UI setup data, empty for AI clients } --- | Server state transformation monad. +-- | Client state transformation monad. newtype CliImplementation resp req a = CliImplementation {runCliImplementation :: StateT (CliState resp req) IO a} deriving (Monad, Functor, Applicative) @@ -84,6 +85,8 @@ ChanServer{requestS} <- gets cliDict IO.liftIO $ atomically . writeTQueue requestS $ scmd +-- | The game-state semantics of atomic commands +-- as computed on the client. instance MonadAtomic (CliImplementation resp req) where execAtomic = handleCmdAtomic 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 @@ -6,11 +6,14 @@ module Game.LambdaHack.SampleImplementation.SampleMonadServer ( executorSer #ifdef EXPOSE_INTERNAL + -- * Internal operations , SerImplementation #endif ) where import Control.Applicative +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 qualified Data.EnumMap.Strict as EM @@ -24,6 +27,7 @@ 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.Server.CommonServer import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.ProtocolServer @@ -75,7 +79,7 @@ SerImplementation $ modify $ \serS -> serS {serDict = s} liftIO = SerImplementation . IO.liftIO --- | The game-state semantics of atomic game commands +-- | The game-state semantics of atomic commands -- as computed on the server. instance MonadAtomic SerImplementation where execAtomic = handleAndBroadcastServer @@ -91,7 +95,7 @@ -- | Run an action in the @IO@ monad, with undefined state. executorSer :: SerImplementation () -> IO () -executorSer m = +executorSer m = do let saveFile (_, ser) = fromMaybe "save" (ssavePrefixSer (sdebugSer ser)) <.> saveName @@ -102,4 +106,14 @@ , serDict = EM.empty , serToSave } - in Save.wrapInSaves saveFile exe + exeWithSaves = Save.wrapInSaves saveFile exe + -- Wait for clients to exit even in case of server crash + -- (or server and client crash), which gives them time to save + -- and report their own inconsistencies, if any. + -- TODO: send them a message to tell users "server crashed" + -- and then wait for them to exit normally. + Ex.handle (\(ex :: Ex.SomeException) -> do + threadDelay 100000 -- let clients report their errors + Ex.throw ex) -- crash eventually, which kills clients + exeWithSaves + waitForChildren childrenServer -- no crash, wait for clients indefinitely diff --git a/Game/LambdaHack/Server.hs b/Game/LambdaHack/Server.hs --- a/Game/LambdaHack/Server.hs +++ b/Game/LambdaHack/Server.hs @@ -3,56 +3,17 @@ -- See -- . module Game.LambdaHack.Server - ( mainSer + ( -- * Re-exported from "Game.LambdaHack.Server.LoopServer" + loopSer + -- * Re-exported from "Game.LambdaHack.Server.MonadServer" + , speedupCOps + -- * Re-exported from "Game.LambdaHack.Server.Commandline" + , debugArgs + -- * Re-exported from "Game.LambdaHack.Server.State" + , sdebugCli ) where -import Control.Concurrent -import qualified Control.Exception as Ex hiding (handle) - -import Game.LambdaHack.Atomic -import Game.LambdaHack.Common.ClientOptions -import Game.LambdaHack.Common.Faction -import qualified Game.LambdaHack.Common.Kind as Kind -import Game.LambdaHack.Common.Request -import Game.LambdaHack.Common.Response -import Game.LambdaHack.Common.Thread import Game.LambdaHack.Server.Commandline import Game.LambdaHack.Server.LoopServer import Game.LambdaHack.Server.MonadServer -import Game.LambdaHack.Server.ProtocolServer import Game.LambdaHack.Server.State - --- | Fire up the frontend with the engine fueled by content. --- The action monad types to be used are determined by the 'exeSer' --- 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 depends on the flags supplied --- when compiling the engine library. -mainSer :: (MonadAtomic m, MonadServerReadRequest m) - => [String] - -> Kind.COps - -> (m () -> IO ()) - -> (Kind.COps -> DebugModeCli - -> ((FactionId -> ChanServer ResponseUI RequestUI - -> IO ()) - -> (FactionId -> ChanServer ResponseAI RequestAI - -> IO ()) - -> IO ()) - -> IO ()) - -> IO () -mainSer args - !copsSlow -- evaluate fully to discover errors ASAP and free memory - exeSer - exeFront = do - sdebugNxt <- debugArgs args - let cops = speedupCOps False copsSlow - exeServer executorUI executorAI = do - -- Wait for clients to exit even in case of server crash - -- (or server and client crash), which gives them time to save. - -- TODO: send them a message to tell users "server crashed" - -- and then let them exit. - Ex.finally - (exeSer (loopSer sdebugNxt executorUI executorAI cops)) - (threadDelay 100000) -- server crashed, show the error eventually - waitForChildren childrenServer -- no crash, wait indefinitely - exeFront cops (sdebugCli sdebugNxt) exeServer 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 @@ -11,6 +11,7 @@ -- TODO: make more maintainable +-- | Parse server debug parameters from commandline arguments. debugArgs :: [String] -> IO DebugModeSer debugArgs args = do let usage = @@ -22,6 +23,7 @@ , " --allClear let all map tiles be translucent" , " --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 start a new game, overwriting the save file" , " --difficulty n set difficulty for all UI players to n" , " --stopAfter n exit this game session after around n seconds" @@ -60,6 +62,8 @@ (parseArgs rest) {sgameMode = Just $ toGroupName (T.pack s)} parseArgs ("--automateAll" : rest) = (parseArgs rest) {sautomateAll = True} + parseArgs ("--keepAutomated" : rest) = + (parseArgs rest) {skeepAutomated = True} parseArgs ("--newGame" : rest) = let debugSer = parseArgs rest in debugSer { snewGameSer = True diff --git a/Game/LambdaHack/Server/CommonServer.hs b/Game/LambdaHack/Server/CommonServer.hs --- a/Game/LambdaHack/Server/CommonServer.hs +++ b/Game/LambdaHack/Server/CommonServer.hs @@ -4,7 +4,7 @@ ( execFailure, resetFidPerception, resetLitInDungeon, getPerFid , revealItems, moveStores, deduceQuits, deduceKilled, electLeader , addActor, addActorIid, projectFail, pickWeaponServer, sumOrganEqpServer - , actorSkillsServer, maxActorSkillsServer + , actorSkillsServer ) where import Control.Applicative @@ -14,7 +14,9 @@ import Data.List import Data.Maybe import Data.Text (Text) +import qualified Data.Text as T import qualified NLP.Miniutter.English as MU +import qualified Text.Show.Pretty as Show.Pretty import Game.LambdaHack.Atomic import qualified Game.LambdaHack.Common.Ability as Ability @@ -57,12 +59,14 @@ let fid = bfid body msg = showReqFailure failureSer impossible = impossibleReqFailure failureSer + debugShow :: Show a => a -> Text + debugShow = T.pack . Show.Pretty.ppShow possiblyAlarm = if impossible then debugPossiblyPrintAndExit else debugPossiblyPrint possiblyAlarm $ "execFailure:" <+> msg <> "\n" - <> tshow body <> "\n" <> tshow req + <> debugShow body <> "\n" <> debugShow req execSfxAtomic $ SfxMsgFid fid $ "Unexpected problem:" <+> msg <> "." -- TODO: --more--, but keep in history @@ -73,11 +77,10 @@ => PersLit -> FactionId -> LevelId -> m Perception resetFidPerception persLit fid lid = do - cops <- getsState scops sfovMode <- getsServer $ sfovMode . sdebugSer lvl <- getLevel lid let fovMode = fromMaybe Digital sfovMode - per = fidLidPerception cops fovMode persLit fid lid lvl + per = fidLidPerception fovMode persLit fid lid lvl upd = EM.adjust (EM.adjust (const per) lid) fid modifyServer $ \ser2 -> ser2 {sper = upd (sper ser2)} return $! per @@ -92,32 +95,40 @@ getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception getPerFid fid lid = do pers <- getsServer sper - let fper = fromMaybe (assert `failure` "no perception for faction" - `twith` (lid, fid)) $ EM.lookup fid pers - per = fromMaybe (assert `failure` "no perception for level" - `twith` (lid, fid)) $ EM.lookup lid fper + let failFact = assert `failure` "no perception for faction" `twith` (lid, fid) + fper = EM.findWithDefault failFact fid pers + failLvl = assert `failure` "no perception for level" `twith` (lid, fid) + per = EM.findWithDefault failLvl lid fper return $! per -- We don't provide ActorId, because the actor can be dead and then, e.g., -- containers with the ActorId are invalid and lead to crashes. revealItems :: (MonadAtomic m, MonadServer m) - => Maybe FactionId -> Maybe Actor -> m () + => Maybe FactionId -> Maybe (ActorId, Actor) -> m () revealItems mfid mbody = do itemToF <- itemToFullServer dungeon <- getsState sdungeon - let discover b iid k = + 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 (blid b) (bpos b) iid itemKindId seed - _ -> assert `failure` (mfid, mbody, iid, itemFull) + execUpdAtomic $ UpdDiscover c iid itemKindId seed + _ -> assert `failure` (mfid, mbody, c, iid, itemFull) f aid = do b <- getsState $ getActorBody aid let ourSide = maybe True (== bfid b) mfid - when (ourSide && Just b /= mbody) $ mapActorItems_ (discover b) b + when ourSide $ + -- CSha is IDed for each actor of each faction, which is OK, + -- even though it may introduce a slight lag. + -- AI clients being sent this is a bigger waste anyway. + join $ getsState $ mapActorItems_ (discover aid) b mapDungeonActors_ f dungeon - maybe skip (\b -> mapActorItems_ (discover b) b) mbody + maybe (return ()) + (\(aid, b) -> do + join $ getsState $ mapActorItems_ (discover aid) b) + mbody moveStores :: (MonadAtomic m, MonadServer m) => ActorId -> CStore -> CStore -> m () @@ -127,45 +138,45 @@ mapActorCStore_ fromStore g b quitF :: (MonadAtomic m, MonadServer m) - => Maybe Actor -> Status -> FactionId -> m () + => Maybe (ActorId, Actor) -> Status -> FactionId -> m () quitF mbody status fid = do - assert (maybe True ((fid ==) . bfid) mbody) skip + let !_A = assert (maybe True ((fid ==) . bfid . snd) mbody) () fact <- getsState $ (EM.! fid) . sfactionD let oldSt = gquit fact - case fmap stOutcome $ oldSt of + 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 when (fhasUI $ gplayer fact) $ do + keepAutomated <- getsServer $ skeepAutomated . sdebugSer + when (isAIFact fact + && fleaderMode (gplayer fact) /= LeaderNull + && not keepAutomated) $ + execUpdAtomic $ UpdAutoFaction fid False revealItems (Just fid) mbody - registerScore status mbody fid - execUpdAtomic $ UpdQuitFaction fid mbody oldSt $ Just status + registerScore status (snd <$> mbody) fid + execUpdAtomic $ UpdQuitFaction fid (snd <$> mbody) oldSt $ Just status -- TODO: send only aid to UpdQuitFaction and elsewhere --- aid is alive modifyServer $ \ser -> ser {squit = True} -- end turn ASAP -- Send any QuitFactionA actions that can be deduced from their current state. -deduceQuits :: (MonadAtomic m, MonadServer m) => Actor -> Status -> m () -deduceQuits body status@Status{stOutcome} +deduceQuits :: (MonadAtomic m, MonadServer m) + => FactionId -> Maybe (ActorId, Actor) -> Status -> m () +deduceQuits fid mbody status@Status{stOutcome} | stOutcome `elem` [Defeated, Camping, Restart, Conquer] = - assert `failure` "no quitting to deduce" `twith` (status, body) -deduceQuits body status = do - let fid = bfid body - mapQuitF statusF fids = mapM_ (quitF Nothing statusF) $ delete fid fids - quitF (Just body) status fid - let inGameOutcome (_, fact) = case fmap stOutcome $ gquit fact of + assert `failure` "no quitting to deduce" `twith` (fid, mbody, status) +deduceQuits fid mbody status = do + let mapQuitF statusF fids = mapM_ (quitF Nothing statusF) $ delete fid fids + quitF mbody status fid + let inGameOutcome (_, fact) = case stOutcome <$> gquit fact of Just Killed -> False Just Defeated -> False Just Restart -> False -- effectively, commits suicide _ -> True - inGame (fid2, fact2) = - if inGameOutcome (fid2, fact2) - then anyActorsAlive fid2 - else return False factionD <- getsState sfactionD - assocsInGame <- filterM inGame $ EM.assocs factionD - let assocsInGameOutcome = filter inGameOutcome $ EM.assocs factionD - keysInGame = map fst assocsInGameOutcome + let assocsInGame = filter inGameOutcome $ EM.assocs factionD + keysInGame = map fst assocsInGame assocsKeepArena = filter (keepArenaFact . snd) assocsInGame assocsUI = filter (fhasUI . gplayer . snd) assocsInGame nonHorrorAIG = filter (not . isHorrorFact . snd) assocsInGame @@ -188,8 +199,8 @@ _ | stOutcome status == Escape -> do -- Otherwise, in a game with many warring teams alive, -- only complete Victory matters, until enough of them die. - let (victors, losers) = partition (flip isAllied fid . snd) - assocsInGameOutcome + let (victors, losers) = + partition (flip isAllied fid . snd) assocsInGame mapQuitF status{stOutcome=Escape} $ map fst victors mapQuitF status{stOutcome=Defeated} $ map fst losers _ -> return () @@ -203,25 +214,30 @@ keepArenaFact fact = fleaderMode (gplayer fact) /= LeaderNull && fneverEmpty (gplayer fact) -deduceKilled :: (MonadAtomic m, MonadServer m) => Actor -> m () -deduceKilled body = do +-- We assume the actor in the second argumet is dead or dominated +-- by this point. Even if the actor is to be dominated, +-- @bfid@ of the actor body is still the old faction. +deduceKilled :: (MonadAtomic m, MonadServer m) + => ActorId -> Actor -> m () +deduceKilled aid body = do Kind.COps{corule} <- getsState scops let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule fid = bfid body fact <- getsState $ (EM.! fid) . sfactionD when (fneverEmpty $ gplayer fact) $ do - actorsAlive <- anyActorsAlive fid + actorsAlive <- anyActorsAlive fid (Just aid) when (not actorsAlive || firstDeathEnds) $ - deduceQuits body $ Status Killed (fromEnum $ blid body) Nothing + deduceQuits fid (Just (aid, body)) + $ Status Killed (fromEnum $ blid body) Nothing -anyActorsAlive :: MonadServer m => FactionId -> m Bool -anyActorsAlive fid = do +anyActorsAlive :: MonadServer m => FactionId -> Maybe ActorId -> m Bool +anyActorsAlive fid maid = do fact <- getsState $ (EM.! fid) . sfactionD if fleaderMode (gplayer fact) /= LeaderNull then return $! isJust $ gleader fact else do - as <- getsState $ fidActorNotProjList fid - return $! not $ null as + as <- getsState $ fidActorNotProjAssocs fid + return $! not $ null $ maybe as (\aid -> filter ((/= aid) . fst) as) maid electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m () electLeader fid lid aidDead = do @@ -282,8 +298,7 @@ if not $ maybe True (bproj . snd . fst) mab then if isBlast && bproj sb then do -- Hit the blocking actor. - projectBla source spos (pos:rest) iid cstore - isBlast + projectBla source spos (pos:rest) iid cstore isBlast return Nothing else return $ Just ProjectBlockActor else do @@ -313,7 +328,7 @@ case iid `EM.lookup` bag of Nothing -> assert `failure` (source, pos, rest, iid, cstore) Just kit@(_, it) -> do - addProjectile source pos rest iid kit lid (bfid sb) localTime isBlast + addProjectile pos rest iid kit lid (bfid sb) localTime isBlast let c = CActor source cstore execUpdAtomic $ UpdLoseItem iid item (1, take 1 it) c @@ -321,10 +336,10 @@ -- -- Projectile has no organs except for the trunk. addProjectile :: (MonadAtomic m, MonadServer m) - => ActorId -> Point -> [Point] -> ItemId -> ItemQuant -> LevelId -> FactionId - -> Time -> Bool + => Point -> [Point] -> ItemId -> ItemQuant -> LevelId + -> FactionId -> Time -> Bool -> m () -addProjectile source bpos rest iid (_, it) blid bfid btime isBlast = do +addProjectile bpos rest iid (_, it) blid bfid btime isBlast = do localTime <- getsState $ getLocalTime blid itemToF <- itemToFullServer let itemFull@ItemFull{itemBase} = itemToF iid (1, take 1 it) @@ -332,12 +347,13 @@ adj | trange < 5 = "falling" | otherwise = "flying" -- Not much detail about a fast flying item. - (object1, object2) = partItem (CActor source CInv) blid localTime $ itemNoDisco (itemBase, 1) + (_, object1, object2) = partItem CInv blid localTime + (itemNoDisco (itemBase, 1)) bname = makePhrase [MU.AW $ MU.Text adj, object1, object2] tweakBody b = b { bsymbol = if isBlast then bsymbol b else '*' , bcolor = if isBlast then bcolor b else Color.BrWhite , bname - , bhp = 0 + , bhp = 1 , bproj = True , btrajectory = Just (trajectory, speed) , beqp = EM.singleton iid (1, take 1 it) @@ -395,7 +411,7 @@ bonusHP = fromIntegral $ (diffHP - hp) `divUp` oneM healthOrgans = [(Just bonusHP, ("bonus HP", COrgan)) | bonusHP /= 0] bsymbol = jsymbol itemBase - bname = jname itemBase + bname = IK.iname trunkKind bcolor = flavourToColor $ jflavour itemBase b = actorTemplate trunkId bsymbol bname bpronoun bcolor diffHP calm pos lid time bfid @@ -410,7 +426,16 @@ $ \(mk, (ikText, cstore)) -> do let container = CActor aid cstore itemFreq = [(ikText, 1)] - void $ rollAndRegisterItem lid itemFreq container False mk + mIidEtc <- rollAndRegisterItem lid itemFreq container False mk + case mIidEtc of + Nothing -> assert `failure` (lid, itemFreq, container, mk) + Just (_, (ItemFull{itemDisco= + Just ItemDisco{itemAE= + Just ItemAspectEffect{jeffects=_:_}}}, _)) -> + return () -- discover by use + Just (iid, _) -> do + seed <- getsServer $ (EM.! iid) . sitemSeedD + execUpdAtomic $ UpdDiscoverSeed container iid seed return $ Just aid -- Server has to pick a random weapon or it could leak item discovery @@ -423,6 +448,7 @@ bodyAssocs <- fullAssocsServer source [COrgan] actorSk <- actorSkillsServer source sb <- getsState $ getActorBody source + localTime <- getsState $ getLocalTime (blid sb) -- For projectiles we need to accept even items without any effect, -- so that the projectile dissapears and NoEffect feedback is produced. let allAssocs = eqpAssocs ++ bodyAssocs @@ -431,7 +457,7 @@ permitted = permittedPrecious calm10 forced legalPrecious = either (const False) (const True) . permitted preferredPrecious = either (const False) id . permitted - strongest = strongestSlotNoFilter IK.EqpSlotWeapon allAssocs + strongest = strongestMelee True localTime allAssocs strongestLegal = filter (legalPrecious . snd . snd) strongest strongestPreferred = filter (preferredPrecious . snd . snd) strongestLegal best = case strongestPreferred of @@ -441,10 +467,9 @@ [] -> strongestLegal case best of [] -> return Nothing - iis -> do - let is = map snd iis - -- TODO: pick the item according to the frequency of its kind. - (iid, _) <- rndToAction $ oneOf is + iis@((maxS, _) : _) -> do + let maxIis = map snd $ takeWhile ((== maxS) . fst) iis + (iid, _) <- rndToAction $ oneOf maxIis let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp return $ Just (iid, cstore) @@ -461,9 +486,3 @@ fact <- getsState $ (EM.! bfid body) . sfactionD let mleader = fst <$> gleader fact getsState $ actorSkills mleader aid activeItems - -maxActorSkillsServer :: MonadServer m - => ActorId -> m Ability.Skills -maxActorSkillsServer aid = do - activeItems <- activeItemsServer aid - getsState $ maxActorSkills aid activeItems diff --git a/Game/LambdaHack/Server/DebugServer.hs b/Game/LambdaHack/Server/DebugServer.hs --- a/Game/LambdaHack/Server/DebugServer.hs +++ b/Game/LambdaHack/Server/DebugServer.hs @@ -6,6 +6,7 @@ import Data.Text (Text) import qualified Data.Text as T +import qualified Text.Show.Pretty as Show.Pretty import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Actor @@ -24,6 +25,9 @@ -- and sent responseQs. Clients interleave and block non-deterministically -- so their logs would be harder to interpret. +debugShow :: Show a => a -> Text +debugShow = T.pack . Show.Pretty.ppShow + debugResponseAI :: MonadServer m => ResponseAI -> m () debugResponseAI cmd = case cmd of RespUpdAtomicAI cmdA@UpdPerception{} -> debugPlain cmd cmdA @@ -33,7 +37,7 @@ RespQueryAI aid -> do d <- debugAid aid "RespQueryAI" cmd serverPrint d - RespPingAI -> serverPrint $ tshow cmd + RespPingAI -> serverPrint $ debugShow cmd debugResponseUI :: MonadServer m => ResponseUI -> m () debugResponseUI cmd = case cmd of @@ -43,19 +47,19 @@ RespUpdAtomicUI cmdA -> debugPretty cmd cmdA RespSfxAtomicUI sfx -> do ps <- posSfxAtomic sfx - serverPrint $ tshow (cmd, ps) - RespQueryUI -> serverPrint $ "RespQueryUI:" <+> tshow cmd - RespPingUI -> serverPrint $ tshow cmd + serverPrint $ debugShow (cmd, ps) + RespQueryUI -> serverPrint $ "RespQueryUI:" <+> debugShow cmd + RespPingUI -> serverPrint $ debugShow cmd debugPretty :: (MonadServer m, Show a) => a -> UpdAtomic -> m () debugPretty cmd cmdA = do ps <- posUpdAtomic cmdA - serverPrint $ tshow (cmd, ps) + serverPrint $ debugShow (cmd, ps) debugPlain :: (MonadServer m, Show a) => a -> UpdAtomic -> m () debugPlain cmd cmdA = do ps <- posUpdAtomic cmdA - serverPrint $ T.pack $ show (cmd, ps) -- too large for pretty show + serverPrint $ T.pack $ show (cmd, ps) -- too large for pretty printing debugRequestAI :: MonadServer m => ActorId -> RequestAI -> m () debugRequestAI aid cmd = do @@ -80,13 +84,13 @@ debugAid :: (MonadStateRead m, Show a) => ActorId -> Text -> a -> m Text debugAid aid label cmd = if aid == toEnum (-1) then - return $ "Pong:" <+> tshow label <+> tshow cmd + return $ "Pong:" <+> debugShow label <+> debugShow cmd else do b <- getsState $ getActorBody aid time <- getsState $ getLocalTime (blid b) - return $! tshow DebugAid { label - , cmd - , lid = blid b - , time - , aid - , faction = bfid b } + return $! debugShow DebugAid { label + , cmd + , lid = blid b + , time + , aid + , faction = bfid 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,13 +1,14 @@ {-# LANGUAGE CPP #-} -- | The unpopulated dungeon generation routine. module Game.LambdaHack.Server.DungeonGen - ( -- * Public API - FreshDungeon(..), dungeonGen + ( FreshDungeon(..), dungeonGen #ifdef EXPOSE_INTERNAL + -- * Internal operations , convertTileMaps, placeStairs, buildLevel, levelFromCaveKind, findGenerator #endif ) where +import Control.Applicative import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM @@ -15,7 +16,6 @@ import Data.List import Data.Maybe -import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc @@ -26,6 +26,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.ItemKind (ItemKind) +import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK @@ -95,7 +96,7 @@ (\p t -> Tile.isWalkable cotile t && not (Tile.hasFeature cotile TK.NoActor t) && dist 0 p t) -- can't overwrite stairs with other stairs - [ dist $ cminStairDist + [ dist cminStairDist , dist $ cminStairDist `div` 2 , dist $ cminStairDist `div` 4 , const $ Tile.hasFeature cotile TK.OftenActor @@ -114,23 +115,23 @@ fitArea pos = inside pos . fromArea . qarea findLegend pos = maybe clegendLitTile qlegend $ find (fitArea pos) dplaces - hasEscape p t = Tile.kindHasFeature (TK.Cause $ IK.Escape p) t + hasEscape p = Tile.kindHasFeature (TK.Cause $ IK.Escape p) ascendable = Tile.kindHasFeature $ TK.Cause (IK.Ascend 1) descendable = Tile.kindHasFeature $ TK.Cause (IK.Ascend (-1)) - nightCond kt = (not (Tile.kindHasFeature TK.Clear kt) - || (if dnight then id else not) - (Tile.kindHasFeature TK.Dark kt)) + nightCond kt = not (Tile.kindHasFeature TK.Clear kt) + || (if dnight then id else not) + (Tile.kindHasFeature TK.Dark kt) dcond kt = (cpassable || not (Tile.kindHasFeature TK.Walkable kt)) && nightCond kt - pickDefTile = fmap (fromMaybe $ assert `failure` cdefTile) - $ opick cdefTile dcond + pickDefTile = (fromMaybe $ assert `failure` cdefTile) + <$> opick cdefTile dcond wcond kt = Tile.kindHasFeature TK.Walkable kt && nightCond kt mpickWalkable = if cpassable - then Just $ fmap (fromMaybe $ assert `failure` cdefTile) - $ opick cdefTile wcond + then Just $ (fromMaybe $ assert `failure` cdefTile) + <$> opick cdefTile wcond else Nothing cmap <- convertTileMaps cops pickDefTile mpickWalkable cxsize cysize dmap -- We keep two-way stairs separately, in the last component. @@ -146,14 +147,14 @@ return (up, down, upDown) else do let cond tk = (if moveUp then ascendable tk else descendable tk) - && (if noAsc then not (ascendable tk) else True) - && (if noDesc then not (descendable tk) else True) + && (not noAsc || not (ascendable tk)) + && (not noDesc || not (descendable tk)) stairsCur = up ++ down ++ upDown posCur = nub $ sort $ map fst stairsCur spos <- placeStairs cops cmap kc posCur let legend = findLegend spos - stairId <- fmap (fromMaybe $ assert `failure` legend) - $ opick legend cond + stairId <- (fromMaybe $ assert `failure` legend) + <$> opick legend cond let st = (spos, stairId) asc = ascendable $ okind stairId desc = descendable $ okind stairId @@ -164,7 +165,7 @@ (False, False) -> assert `failure` st (stairsUp1, stairsDown1, stairsUpDown1) <- makeStairs False (ln == maxD) (ln == minD) ([], [], []) - assert (null stairsUp1) skip + let !_A = assert (null stairsUp1) () let nstairUpLeft = nstairUp - length stairsUpDown1 (stairsUp2, stairsDown2, stairsUpDown2) <- foldM (\sts _ -> makeStairs True (ln == maxD) (ln == minD) sts) @@ -172,12 +173,12 @@ [1 .. nstairUpLeft] -- If only a single tile of up-and-down stairs, add one more stairs down. (stairsUp, stairsDown, stairsUpDown) <- - if length (stairsUp2 ++ stairsDown2) == 0 - then (makeStairs False True (ln == minD) - (stairsUp2, stairsDown2, stairsUpDown2)) + if null (stairsUp2 ++ stairsDown2) + then makeStairs False True (ln == minD) + (stairsUp2, stairsDown2, stairsUpDown2) else return (stairsUp2, stairsDown2, stairsUpDown2) let stairsUpAndUpDown = stairsUp ++ stairsUpDown - assert (length stairsUpAndUpDown == nstairUp) skip + let !_A = assert (length stairsUpAndUpDown == nstairUp) () let stairsTotal = stairsUpAndUpDown ++ stairsDown posTotal = nub $ sort $ map fst stairsTotal epos <- placeStairs cops cmap kc posTotal @@ -203,12 +204,12 @@ lsecret <- randomR (1, maxBound) -- 0 means unknown return $! levelFromCaveKind cops kc ldepth ltile lstair cactorCoeff cactorFreq litemNum citemFreq - lsecret (isJust escapeFeature) + lsecret (map fst escape) -- | Build rudimentary level from a cave kind. levelFromCaveKind :: Kind.COps -> CaveKind -> AbsDepth -> TileMap -> ([Point], [Point]) - -> Int -> Freqs ItemKind -> Int -> Freqs ItemKind -> Int -> Bool + -> Int -> Freqs ItemKind -> Int -> Freqs ItemKind -> Int -> [Point] -> Level levelFromCaveKind Kind.COps{cotile} CaveKind{..} @@ -247,8 +248,8 @@ findGenerator cops ln minD maxD totalDepth nstairUp (genName, escapeFeature) = do let Kind.COps{cocave=Kind.Ops{opick}} = cops - ci <- fmap (fromMaybe $ assert `failure` genName) - $ opick genName (const True) + ci <- (fromMaybe $ assert `failure` genName) + <$> opick genName (const True) -- A simple rule for now: level at level @ln@ has depth (difficulty) @abs ln@. let ldepth = AbsDepth $ abs $ fromEnum ln cave <- buildCave cops ldepth totalDepth ci @@ -278,8 +279,8 @@ lvl <- findGenerator cops ln minId maxId freshTotalDepth nstairUp caveTB -- nstairUp for the next level is nstairDown for the current level let nstairDown = length $ snd $ lstair lvl - return $ (nstairDown, (ln, lvl) : l) + return (nstairDown, (ln, lvl) : l) (nstairUpLast, levels) <- foldM gen (0, []) $ reverse $ IM.assocs caves - assert (nstairUpLast == 0) skip + let !_A = assert (nstairUpLast == 0) () let freshDungeon = EM.fromList levels return $! FreshDungeon{..} 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 @@ -34,7 +34,7 @@ -> Rnd Area mkRoom (xm, ym) (xM, yM) area = do let (x0, y0, x1, y1) = fromArea area - assert (xm <= x1 - x0 + 1 && ym <= y1 - y0 + 1) skip + let !_A = assert (xm <= x1 - x0 + 1 && ym <= y1 - y0 + 1) () let aW = (xm, ym, min xM (x1 - x0 + 1), min yM (y1 - y0 + 1)) areaW = fromMaybe (assert `failure` aW) $ toArea aW Point xW yW <- xyInArea areaW -- roll size @@ -140,9 +140,9 @@ (_, _, sox1, soy1) = fromArea so (tx0, ty0, _, _) = fromArea ta (tox0, toy0, _, _) = fromArea to - assert (sx1 <= tx0 || sy1 <= ty0 `blame` (sa, ta)) skip - assert (sx1 <= sox1 || sy1 <= soy1 `blame` (sa, so)) skip - assert (tx0 >= tox0 || ty0 >= toy0 `blame` (ta, to)) skip + let !_A = assert (sx1 <= tx0 || sy1 <= ty0 `blame` (sa, ta)) () + let !_A = assert (sx1 <= sox1 || sy1 <= soy1 `blame` (sa, so)) () + let !_A = assert (tx0 >= tox0 || ty0 >= toy0 `blame` (ta, to)) () let trim area = let (x0, y0, x1, y1) = fromArea area trim4 (v0, v1) | v1 - v0 < 6 = (v0, v1) diff --git a/Game/LambdaHack/Server/DungeonGen/Cave.hs b/Game/LambdaHack/Server/DungeonGen/Cave.hs --- a/Game/LambdaHack/Server/DungeonGen/Cave.hs +++ b/Game/LambdaHack/Server/DungeonGen/Cave.hs @@ -3,6 +3,7 @@ ( Cave(..), buildCave ) where +import Control.Applicative import Control.Arrow ((&&&)) import Control.Exception.Assert.Sugar import Control.Monad @@ -80,7 +81,7 @@ || couterFenceTile /= "basic outer fence" = subFullArea | otherwise = fullArea gs = grid lgrid area - (addedConnects, voidPlaces) <- do + (addedConnects, voidPlaces) <- if gx * gy > 1 then do let fractionOfPlaces r = round $ r * fromIntegral (gx * gy) cauxNum = fractionOfPlaces cauxConnects @@ -98,16 +99,16 @@ let innerArea = fromMaybe (assert `failure` (i, r)) $ shrink r r' <- if i `elem` voidPlaces - then fmap Left $ mkVoidRoom innerArea - else fmap Right $ mkRoom minPlaceSize + then Left <$> mkVoidRoom innerArea + else Right <$> mkRoom minPlaceSize maxPlaceSize innerArea return (i, r')) gs fence <- buildFenceRnd cops couterFenceTile subFullArea dnight <- chanceDice ldepth totalDepth cnightChance - darkCorTile <- fmap (fromMaybe $ assert `failure` cdarkCorTile) - $ opick cdarkCorTile (const True) - litCorTile <- fmap (fromMaybe $ assert `failure` clitCorTile) - $ opick clitCorTile (const True) + darkCorTile <- fromMaybe (assert `failure` cdarkCorTile) + <$> opick cdarkCorTile (const True) + litCorTile <- fromMaybe (assert `failure` clitCorTile) + <$> opick clitCorTile (const True) let pickedCorTile = if dnight then darkCorTile else litCorTile addPl (m, pls, qls) (i, Left r) = return (m, pls, (i, Left r) : qls) addPl (m, pls, qls) (i, Right r) = do @@ -116,7 +117,7 @@ return (EM.union tmap m, place : pls, (i, Right (r, place)) : qls) (lplaces, dplaces, qplaces0) <- foldM addPl (fence, [], []) places0 connects <- connectGrid lgrid - let allConnects = union connects addedConnects -- no duplicates + let allConnects = connects `union` addedConnects -- no duplicates qplaces = M.fromList qplaces0 cs <- mapM (\(p0, p1) -> do let shrinkPlace (r, Place{qkind}) = 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 @@ -4,6 +4,7 @@ ( TileMapEM, Place(..), placeCheck, buildFenceRnd, buildPlace ) where +import Control.Applicative import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.EnumMap.Strict as EM @@ -97,28 +98,31 @@ , coplace=Kind.Ops{ofoldrGroup} } CaveKind{..} dnight darkCorTile litCorTile ldepth@(AbsDepth ld) totalDepth@(AbsDepth depth) r = do - qFWall <- fmap (fromMaybe $ assert `failure` cfillerTile) - $ opick cfillerTile (const True) + qFWall <- fromMaybe (assert `failure` cfillerTile) + <$> opick cfillerTile (const True) dark <- chanceDice ldepth totalDepth cdarkChance -- TODO: factor out from here and newItem: let findInterval x1y1 [] = (x1y1, (11, 0)) findInterval x1y1 ((x, y) : rest) = - if ld * 10 <= x * depth + if fromIntegral ld * 10 <= x * fromIntegral depth then (x1y1, (x, y)) else findInterval (x, y) rest linearInterpolation dataset = - -- We assume @dataset@ is sorted and between 1 and 10 inclusive. + -- We assume @dataset@ is sorted and between 0 and 10. let ((x1, y1), (x2, y2)) = findInterval (0, 0) dataset - in y1 + (y2 - y1) * (ld * 10 - x1 * depth) - `divUp` ((x2 - x1) * depth) + in ceiling + $ fromIntegral y1 + + fromIntegral (y2 - y1) + * (fromIntegral ld * 10 - x1 * fromIntegral depth) + / ((x2 - x1) * fromIntegral depth) let f placeGroup q p pk kind acc = let rarity = linearInterpolation (prarity kind) in (q * p * rarity, ((pk, kind), placeGroup)) : acc g (placeGroup, q) = ofoldrGroup placeGroup (f placeGroup q) [] placeFreq = concatMap g cplaceFreq checkedFreq = filter (\(_, ((_, kind), _)) -> placeCheck r kind) placeFreq - freq = toFreq ("buildPlace ('" <> tshow ld <> ")") checkedFreq - assert (not (nullFreq freq) `blame` (placeFreq, checkedFreq, r)) skip + freq = toFreq ("buildPlace" <+> tshow (map fst checkedFreq)) checkedFreq + let !_A = assert (not (nullFreq freq) `blame` (placeFreq, checkedFreq, r)) () ((qkind, kr), _) <- frequency freq let qFFloor = if dark then darkCorTile else litCorTile qFGround = if dnight then darkCorTile else litCorTile @@ -143,8 +147,8 @@ | otherwise = xlegend EM.! c interior = case pfence kr of FNone | not dnight -> EM.mapWithKey digDay cmap - _ -> let lookupLegend x = fromMaybe (assert `failure` (qlegend, x)) - $ EM.lookup x xlegend + _ -> let lookupLegend x = + EM.findWithDefault (assert `failure` (qlegend, x)) x xlegend in EM.map lookupLegend cmap tmap = EM.union interior fence return (tmap, place) @@ -170,8 +174,8 @@ ooverride Kind.COps{cotile=Kind.Ops{opick}} poverride = let getLegend (s, cgroup) acc = do m <- acc - tk <- fmap (fromMaybe $ assert `failure` (cgroup, s)) - $ opick cgroup (const True) -- tile symbol ignored + tk <- fromMaybe (assert `failure` (cgroup, s)) + <$> opick cgroup (const True) -- tile symbol ignored return $! EM.insert s tk m legend = foldr getLegend (return EM.empty) poverride in legend @@ -193,8 +197,8 @@ let isCorner x y = x `elem` [x0-1, x1+1] && y `elem` [y0-1, y1+1] tileGroup | isCorner xf yf = "basic outer fence" | otherwise = couterFenceTile - fenceId <- fmap (fromMaybe $ assert `failure` tileGroup) - $ opick tileGroup (const True) + fenceId <- fromMaybe (assert `failure` tileGroup) + <$> opick tileGroup (const True) return (Point xf yf, fenceId) pointList = [ (x, y) | x <- [x0-1, x1+1], y <- [y0..y1] ] ++ [ (x, y) | x <- [x0-1..x1+1], y <- [y0-1, y1+1] ] @@ -216,8 +220,7 @@ (dx, dy) = assert (xwidth >= dxcorner && ywidth >= length ptopLeft `blame` (area, pl)) (xwidth, ywidth) - fromX (x2, y2) = - zipWith (\x y -> Point x y) [x2..] (repeat y2) + fromX (x2, y2) = map (`Point` y2) [x2..] fillInterior :: (forall a. Int -> [a] -> [a]) -> [(Point, Char)] fillInterior f = let tileInterior (y, row) = diff --git a/Game/LambdaHack/Server/EndServer.hs b/Game/LambdaHack/Server/EndServer.hs --- a/Game/LambdaHack/Server/EndServer.hs +++ b/Game/LambdaHack/Server/EndServer.hs @@ -16,6 +16,7 @@ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State +import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Server.CommonServer import Game.LambdaHack.Server.HandleEffectServer import Game.LambdaHack.Server.ItemServer @@ -24,7 +25,8 @@ -- | Continue or exit or restart the game. endOrLoop :: (MonadAtomic m, MonadServer m) - => m () -> m () -> m () -> m () -> m () + => m () -> (Maybe (GroupName ModeKind) -> m ()) -> m () -> m () + -> m () endOrLoop loop restart gameExit gameSave = do factionD <- getsState sfactionD let inGame fact = case gquit fact of @@ -49,16 +51,13 @@ modifyServer $ \ser -> ser {swriteSave = False} gameSave case (quitters, campers) of - (gameMode : _, _) -> do - modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) - {sgameMode = Just gameMode}} - restart - _ | gameOver -> restart + (gameMode : _, _) -> restart $ Just gameMode + _ | gameOver -> restart Nothing ([], []) -> loop -- continue current game ([], _ : _) -> gameExit -- don't call @loop@, that is, quit the game loop dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> Bool -> m () -dieSer aid b hit = do +dieSer aid b hit = -- TODO: clients don't see the death of their last standing actor; -- modify Draw.hs and Client.hs to handle that if bproj b then do @@ -71,22 +70,21 @@ let ikind = discoKind EM.! jkindIx trunk execUpdAtomic $ UpdRecordKill aid ikind 1 electLeader (bfid b) (blid b) aid + tb <- getsState $ getActorBody aid + deduceKilled aid tb -- tb has items not dropped, stash in inv + fact <- getsState $ (EM.! bfid b) . sfactionD + -- Prevent faction's stash from being lost in case they are not spawners. + -- 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 aid CSha CInv dropAllItems aid b False b2 <- getsState $ getActorBody aid execUpdAtomic $ UpdDestroyActor aid b2 [] - deduceKilled b -- | Drop all actor's items. dropAllItems :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> Bool -> m () dropAllItems aid b hit = do - fact <- getsState $ (EM.! bfid b) . sfactionD - -- A faction that is defeated, leaderless or with temporarlity no member - -- drops all items from the faction stash, too. - -- 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 (not (bproj b) && isNothing (gleader fact)) $ - mapActorCStore_ CSha (dropCStoreItem CSha aid b hit) b mapActorCStore_ CInv (dropCStoreItem CInv aid b hit) b mapActorCStore_ CEqp (dropCStoreItem CEqp aid b hit) b 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 @@ -6,34 +6,28 @@ ( dungeonPerception, fidLidPerception , PersLit, litInDungeon #ifdef EXPOSE_INTERNAL - , PerceptionLit, ActorEqpBody + -- * Internal operations + , PerceptionReachable(..), PerceptionDynamicLit(..) #endif ) where -import Control.Exception.Assert.Sugar import qualified Data.EnumMap.Lazy as EML import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Data.Function import Data.List import Data.Maybe -import Data.Ord import 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.Perception import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector -import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Server.Fov.Common import qualified Game.LambdaHack.Server.Fov.Digital as Digital @@ -41,60 +35,63 @@ import qualified Game.LambdaHack.Server.Fov.Shadow as Shadow import Game.LambdaHack.Server.State --- | Visually reachable position (light passes through them to the actor). +-- | Visually reachable positions (light passes through them to the actor). +-- The list may contain (many) repetitions. newtype PerceptionReachable = PerceptionReachable {preachable :: [Point]} deriving Show --- | All lit positions on a level. -newtype PerceptionLit = PerceptionLit - {plit :: ES.EnumSet Point} +-- | All positions lit by dynamic lights on a level. Shared by all factions. +-- The list may contain (many) repetitions. +newtype PerceptionDynamicLit = PerceptionDynamicLit + {pdynamicLit :: [Point]} deriving Show -type ActorEqpBody = [((ActorId, Actor), [ItemFull])] - -type PersLit = EML.EnumMap LevelId ( PerceptionLit - , EM.EnumMap FactionId ActorEqpBody +-- | The cache of FOV information for a level, such as sight, smell +-- and light radiuses for each actor and bitmaps of clear and lit positions. +type PersLit = EML.EnumMap LevelId ( EM.EnumMap FactionId [(Actor, FovCache3)] + , PointArray.Array Bool , PointArray.Array Bool ) -- | Calculate faction's perception of a level. -levelPerception :: Kind.COps - -> PerceptionLit -> ActorEqpBody -> PointArray.Array Bool +levelPerception :: [(Actor, FovCache3)] + -> PointArray.Array Bool -> PointArray.Array Bool -> FovMode -> Level -> Perception -levelPerception cops litHere actorEqpBody blockers - fovMode lvl@Level{lxsize, lysize} = +levelPerception actorEqpBody clearPs litPs fovMode Level{lxsize, lysize} = let -- Dying actors included, to let them see their own demise. - ours = filter (not . bproj . snd . fst) actorEqpBody - ourR = preachable . reachableFromActor blockers fovMode - totalReachable = PerceptionReachable $ concatMap ourR ours + ourR = preachable . reachableFromActor clearPs fovMode + totalReachable = PerceptionReachable $ concatMap ourR actorEqpBody + -- All non-projectile actors feel adjacent positions, + -- even dark (for easy exploration). Projectiles rely on cameras. pAndVicinity p = p : vicinity lxsize lysize p - -- All actors feel adjacent positions, even dark (for easy exploration). - noctoBodies = map (\aEB@((_, b), _) -> (pAndVicinity (bpos b), aEB)) ours - nocto = concat $ map fst noctoBodies - ptotal = visibleOnLevel cops totalReachable litHere nocto lvl - canSmellAround (_, allAssocs) = - let radius = sumSlotNoFilter IK.EqpSlotAddSmell allAssocs - in radius >= 2 + gatherVicinities = concatMap (pAndVicinity . bpos . fst) + nocteurs = filter (not . bproj . fst) actorEqpBody + nocto = gatherVicinities nocteurs + ptotal = visibleOnLevel totalReachable litPs nocto -- TODO: handle smell radius < 2, that is only under the actor - -- TODO: filter out tiles that are solid and so can't hold smell. - psmell = PerceptionVisible $ ES.fromList - $ concat $ map fst $ filter (canSmellAround . snd) noctoBodies + -- Projectiles can potentially smell, too. + canSmellAround FovCache3{fovSmell} = fovSmell >= 2 + smellers = filter (canSmellAround . snd) actorEqpBody + smells = gatherVicinities smellers + -- No smell stored in walls and under other actors. + canHoldSmell p = clearPs PointArray.! p + psmell = PerceptionVisible $ ES.fromList $ filter canHoldSmell smells in Perception ptotal psmell -- | Calculate faction's perception of a level based on the lit tiles cache. -fidLidPerception :: Kind.COps -> FovMode -> PersLit +fidLidPerception :: FovMode -> PersLit -> FactionId -> LevelId -> Level -> Perception -fidLidPerception cops fovMode persLit fid lid lvl = - let (litHere, bodyMap, blockers) = persLit EML.! lid +fidLidPerception fovMode persLit fid lid lvl = + let (bodyMap, clearPs, litPs) = persLit EML.! lid actorEqpBody = EM.findWithDefault [] fid bodyMap - in levelPerception cops litHere actorEqpBody blockers fovMode lvl + in levelPerception actorEqpBody clearPs litPs fovMode lvl -- | Calculate perception of a faction. factionPerception :: FovMode -> PersLit -> FactionId -> State -> FactionPers factionPerception fovMode persLit fid s = - EM.mapWithKey (fidLidPerception (scops s) fovMode persLit fid) $ sdungeon s + EM.mapWithKey (fidLidPerception fovMode persLit fid) $ sdungeon s -- | Calculate the perception of the whole dungeon. dungeonPerception :: FovMode -> State -> StateServer -> Pers @@ -108,91 +105,87 @@ -- light source, e.g,, carried by an actor. A reachable and lit position -- is visible. Additionally, positions directly adjacent to an actor are -- assumed to be visible to him (through sound, touch, noctovision, whatever). -visibleOnLevel :: Kind.COps -> PerceptionReachable - -> PerceptionLit -> [Point] -> Level +visibleOnLevel :: PerceptionReachable + -> PointArray.Array Bool -> [Point] -> PerceptionVisible -visibleOnLevel Kind.COps{cotile} - PerceptionReachable{preachable} PerceptionLit{plit} - nocto lvl = - -- TODO: costly - -- TODO: make a vector mask from isVisible; possibly of PerceptionVisible, too - let isVisible pos = Tile.isLit cotile (lvl `at` pos) || pos `ES.member` plit +visibleOnLevel PerceptionReachable{preachable} litPs nocto = + let isVisible = (litPs PointArray.!) in PerceptionVisible $ ES.fromList $ nocto ++ filter isVisible preachable -- | Compute positions reachable by the actor. Reachable are all fields -- on a visually unblocked path from the actor position. -reachableFromActor :: PointArray.Array Bool -> FovMode - -> ((ActorId, Actor), [ItemFull]) +reachableFromActor :: PointArray.Array Bool -> FovMode -> (Actor, FovCache3) -> PerceptionReachable -reachableFromActor blockers fovMode ((_, body), allItems) = - let sumSight = sumSlotNoFilter IK.EqpSlotAddSight allItems - radius = min (fromIntegral $ bcalm body `div` (5 * oneM)) sumSight - in PerceptionReachable $ fullscan blockers fovMode radius (bpos body) +reachableFromActor clearPs fovMode (body, FovCache3{fovSight}) = + let radius = min (fromIntegral $ bcalm body `div` (5 * oneM)) fovSight + in PerceptionReachable $ fullscan clearPs fovMode radius (bpos body) --- | Compute all lit positions on a level, whether lit by actors or floor items. --- Note that an actor can be blind or a projectile, in which case he doesn't see +-- | Compute all dynamically lit positions on a level, whether lit by actors +-- or floor items. Note that an actor can be blind, in which case he doesn't see -- his own light (but others, from his or other factions, possibly do). -litByItems :: Kind.COps -> PointArray.Array Bool -> FovMode -> Level - -> [(Point, [ItemFull])] - -> PerceptionLit -litByItems Kind.COps{cotile} blockers fovMode lvl allItems = - let litPos :: (Point, [ItemFull]) -> [Point] - litPos (p, is) = - let radius = sumSlotNoFilter IK.EqpSlotAddLight is - scan = fullscan blockers fovMode radius p - -- Optimization: filter out positions already having ambient light. - opt = filter (\pos -> not $ Tile.isLit cotile $ lvl `at` pos) scan - in opt - litAll = concatMap litPos allItems - in PerceptionLit $ ES.fromList litAll +litByItems :: PointArray.Array Bool -> FovMode -> [(Point, Int)] + -> PerceptionDynamicLit +litByItems clearPs fovMode allItems = + let litPos :: (Point, Int) -> [Point] + litPos (p, light) = fullscan clearPs fovMode light p + in PerceptionDynamicLit $ concatMap litPos allItems --- | Compute all lit positions in the dungeon +-- | Compute all lit positions in the dungeon. litInDungeon :: FovMode -> State -> StateServer -> PersLit litInDungeon fovMode s ser = - let cops@Kind.COps{cotile} = scops s - itemsInActors :: Level -> EM.EnumMap FactionId ActorEqpBody + let Kind.COps{cotile} = scops s + processIid3 (FovCache3 sightAcc smellAcc lightAcc) (iid, (k, _)) = + let FovCache3{..} = + EM.findWithDefault emptyFovCache3 iid $ sItemFovCache ser + in FovCache3 (k * fovSight + sightAcc) + (k * fovSmell + smellAcc) + (k * fovLight + lightAcc) + processBag3 bag acc = foldl' processIid3 acc $ EM.assocs bag + itemsInActors :: Level -> EM.EnumMap FactionId [(Actor, FovCache3)] itemsInActors lvl = - let asLid = map (\aid -> (aid, getActorBody aid s)) - $ concat $ EM.elems $ lprio lvl - asGrouped = groupBy ((==) `on` (bfid . snd)) - $ sortBy (comparing (bfid . snd)) asLid - bodyFid :: [(ActorId, Actor)] -> (FactionId, ActorEqpBody) - bodyFid [] = assert `failure` asGrouped - bodyFid asFid@((_, bFid) : _) = - let fid = bfid bFid - eqpBody (aid, b) = - ( (aid, b) - , map snd $ fullAssocs cops (sdiscoKind ser) (sdiscoEffect ser) - aid [COrgan, CEqp] s ) - in (fid, map eqpBody asFid) - in EM.fromDistinctAscList $ map bodyFid asGrouped - itemsOnFloor :: Level -> [(Point, [ItemFull])] - itemsOnFloor lvl = - let iToFull (iid, (item, kit)) = - itemToFull cops (sdiscoKind ser) (sdiscoEffect ser) iid item kit - processPos (p, bag) = - (p, map iToFull $ bagAssocsK s bag) - in map processPos $ EM.assocs $ lfloor lvl -- lembed are covered - -- Note that an actor can be blind or a projectile, + let processActor aid = + let b = getActorBody aid s + sslOrgan = processBag3 (borgan b) emptyFovCache3 + ssl = processBag3 (beqp b) sslOrgan + in (bfid b, [(b, ssl)]) + asLid = map processActor $ concat $ EM.elems $ lprio lvl + in EM.fromListWith (++) asLid + processIid lightAcc (iid, (k, _)) = + let FovCache3{fovLight} = + EM.findWithDefault emptyFovCache3 iid $ sItemFovCache ser + in k * fovLight + lightAcc + processBag bag acc = foldl' processIid acc $ EM.assocs bag + lightOnFloor :: Level -> [(Point, Int)] + lightOnFloor lvl = + let processPos (p, bag) = (p, processBag bag 0) + in map processPos $ EM.assocs $ lfloor lvl -- lembed are hidden + -- Note that an actor can be blind, -- in which case he doesn't see his own light -- (but others, from his or other factions, possibly do). - litOnLevel :: Level -> ( PerceptionLit - , EM.EnumMap FactionId ActorEqpBody + litOnLevel :: Level -> ( EM.EnumMap FactionId [(Actor, FovCache3)] + , PointArray.Array Bool , PointArray.Array Bool ) litOnLevel lvl@Level{ltile} = let bodyMap = itemsInActors lvl allBodies = concat $ EM.elems bodyMap - blockingTiles = PointArray.mapA (Tile.isClear cotile) ltile - blockFromBody ((_, b), _) = + clearTiles = PointArray.mapA (Tile.isClear cotile) ltile + blockFromBody (b, _) = if bproj b then Nothing else Just (bpos b, False) -- TODO: keep it in server state and update when tiles change -- and actors are born/move/die. Actually, do this for PersLit. blockingActors = mapMaybe blockFromBody allBodies - blockers = blockingTiles PointArray.// blockingActors - actorItems = map (\((_, b), iis) -> (bpos b, iis)) allBodies - floorItems = itemsOnFloor lvl - allItems = floorItems ++ actorItems - in (litByItems cops blockers fovMode lvl allItems, bodyMap, blockers) + clearPs = clearTiles PointArray.// blockingActors + litTiles = PointArray.mapA (Tile.isLit cotile) ltile + actorLights = map (\(b, FovCache3{fovLight}) -> (bpos b, fovLight)) + allBodies + floorLights = lightOnFloor lvl + -- If there is light both on the floor and carried by actor, + -- only the stronger light is taken into account. + -- This is rare, so no point optimizing away the double computation. + allLights = floorLights ++ actorLights + litDynamic = pdynamicLit $ litByItems clearPs fovMode allLights + litPs = litTiles PointArray.// map (\p -> (p, True)) litDynamic + in (bodyMap, clearPs, litPs) litLvl (lid, lvl) = (lid, litOnLevel lvl) in EML.fromDistinctAscList $ map litLvl $ EM.assocs $ sdungeon s @@ -205,20 +198,21 @@ -> Int -- ^ scanning radius -> Point -- ^ position of the spectator -> [Point] -fullscan blockers fovMode radius spectatorPos = - if radius <= 0 then [] - else if radius == 1 then [spectatorPos] - else spectatorPos : case fovMode of - Shadow -> - concatMap (\tr -> map tr (Shadow.scan (isCl . tr) 1 (0, 1))) tr8 - Permissive -> - concatMap (\tr -> map tr (Permissive.scan (isCl . tr))) tr4 - Digital -> - concatMap (\tr -> map tr (Digital.scan (radius - 1) (isCl . tr))) tr4 +fullscan clearPs fovMode radius spectatorPos + | radius <= 0 = [] + | radius == 1 = [spectatorPos] + | otherwise = + spectatorPos : case fovMode of + Shadow -> + concatMap (\tr -> map tr (Shadow.scan (isCl . tr) 1 (0, 1))) tr8 + Permissive -> + concatMap (\tr -> map tr (Permissive.scan (isCl . tr))) tr4 + Digital -> + concatMap (\tr -> map tr (Digital.scan (radius - 1) (isCl . tr))) tr4 where isCl :: Point -> Bool {-# INLINE isCl #-} - isCl = (blockers PointArray.!) + isCl = (clearPs PointArray.!) -- This function is cheap, so no problem it's called twice -- for each point: once with @isCl@, once via @concatMap@. diff --git a/Game/LambdaHack/Server/Fov/Digital.hs b/Game/LambdaHack/Server/Fov/Digital.hs --- a/Game/LambdaHack/Server/Fov/Digital.hs +++ b/Game/LambdaHack/Server/Fov/Digital.hs @@ -1,8 +1,13 @@ +{-# LANGUAGE CPP #-} -- | DFOV (Digital Field of View) implemented according to specification at . -- This fast version of the algorithm, based on "PFOV", has AFAIK -- never been described nor implemented before. module Game.LambdaHack.Server.Fov.Digital - ( scan, dline, dsteeper, intersect, debugSteeper, debugLine + ( scan +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , dline, dsteeper, intersect, _debugSteeper, _debugLine +#endif ) where import Control.Exception.Assert.Sugar @@ -80,14 +85,21 @@ {-# INLINE dline #-} dline p1 p2 = let line = Line p1 p2 - in assert (uncurry blame $ debugLine line) line + in +#ifdef WITH_EXPENSIVE_ASSERTIONS + assert (uncurry blame $ _debugLine line) +#endif + line -- | Compare steepness of @(p1, f)@ and @(p2, f)@. -- Debug: Verify that the results of 2 independent checks are equal. dsteeper :: Bump -> Bump -> Bump -> Bool {-# INLINE dsteeper #-} dsteeper f p1 p2 = - assert (res == debugSteeper f p1 p2) res +#ifdef WITH_EXPENSIVE_ASSERTIONS + assert (res == _debugSteeper f p1 p2) +#endif + res where res = steeper f p1 p2 -- | The X coordinate, represented as a fraction, of the intersection of @@ -96,7 +108,9 @@ intersect :: Line -> Distance -> (Int, Int) {-# INLINE intersect #-} intersect (Line (B x y) (B xf yf)) d = +#ifdef WITH_EXPENSIVE_ASSERTIONS assert (allB (>= 0) [y, yf]) +#endif ((d - y)*(xf - x) + x*(yf - y), yf - y) {- Derivation of the formula: @@ -130,18 +144,18 @@ -- | Debug functions for DFOV: -- | Debug: calculate steeper for DFOV in another way and compare results. -debugSteeper :: Bump -> Bump -> Bump -> Bool -{-# INLINE debugSteeper #-} -debugSteeper f@(B _xf yf) p1@(B _x1 y1) p2@(B _x2 y2) = +_debugSteeper :: Bump -> Bump -> Bump -> Bool +{-# INLINE _debugSteeper #-} +_debugSteeper f@(B _xf yf) p1@(B _x1 y1) p2@(B _x2 y2) = assert (allB (>= 0) [yf, y1, y2]) $ let (n1, k1) = intersect (Line p1 f) 0 (n2, k2) = intersect (Line p2 f) 0 in n1 * k2 >= k1 * n2 -- | Debug: check if a view border line for DFOV is legal. -debugLine :: Line -> (Bool, String) -{-# INLINE debugLine #-} -debugLine line@(Line (B x1 y1) (B x2 y2)) +_debugLine :: Line -> (Bool, String) +{-# INLINE _debugLine #-} +_debugLine line@(Line (B x1 y1) (B x2 y2)) | not (allB (>= 0) [y1, y2]) = (False, "negative coordinates: " ++ show line) | y1 == y2 && x1 == x2 = diff --git a/Game/LambdaHack/Server/HandleEffectServer.hs b/Game/LambdaHack/Server/HandleEffectServer.hs --- a/Game/LambdaHack/Server/HandleEffectServer.hs +++ b/Game/LambdaHack/Server/HandleEffectServer.hs @@ -52,7 +52,7 @@ applyItem :: (MonadAtomic m, MonadServer m) => ActorId -> ItemId -> CStore -> m () applyItem aid iid cstore = do - execSfxAtomic $ SfxActivate aid iid cstore + execSfxAtomic $ SfxApply aid iid cstore let c = CActor aid cstore itemEffectAndDestroy aid aid iid c @@ -84,12 +84,12 @@ let it1 = case mtimeout of Just (IK.Timeout timeout) -> let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout - pending startT = timeShift startT timeoutTurns > localTime - in filter pending it + charging startT = timeShift startT timeoutTurns > localTime + in filter charging it _ -> [] len = length it1 recharged = len < k - assert (len <= k `blame` (kitK, source, target, iid, c)) skip + let !_A = assert (len <= k `blame` (kitK, source, target, iid, c)) () -- If there is no Timeout, but there are Recharging, -- then such effects are disabled whenever the item is affected -- by a Discharge attack (TODO). @@ -99,8 +99,12 @@ _ -> -- TODO: if has timeout and not recharged, report failure return it1 - when (it /= it2 && mtimeout /= Just (IK.Timeout 0)) $ - execUpdAtomic $ UpdTimeItem iid c it it2 + -- We use up the charge even if eventualy every effect fizzles. Tough luck. + -- At least we don't destroy the item in such case. Also, we ID it regardless. + it3 <- if it /= it2 && mtimeout /= Just (IK.Timeout 0) then do + execUpdAtomic $ UpdTimeItem iid c it it2 + return it2 + else return it -- If the activation is not periodic, trigger at least the effects -- that are not recharging and so don't depend on @recharged@. when (not periodic || recharged) $ do @@ -119,12 +123,12 @@ item <- getsState $ getItemBody iid let durable = IK.Durable `elem` jfeature item imperishable = durable || periodic && isNothing mtmp - kit = if isNothing mtmp || periodic then (1, take 1 it2) else (k, it2) + kit = if isNothing mtmp || periodic then (1, take 1 it3) else (k, it3) unless imperishable $ execUpdAtomic $ UpdLoseItem iid item kit c -- At this point, the item is potentially no longer in container @c@, -- so we don't pass @c@ along. - triggered <- itemEffectDisco source target iid recharged periodic effs + triggered <- itemEffectDisco source target iid c recharged periodic effs -- If none of item's effects was performed, we try to recreate the item. -- Regardless, we don't rewind the time, because some info is gained -- (that the item does not exhibit any effects in the given context). @@ -155,28 +159,17 @@ -- is mutually recursive with @effect@ and so it's a part of @Effect@ -- semantics. itemEffectDisco :: (MonadAtomic m, MonadServer m) - => ActorId -> ActorId -> ItemId -> Bool -> Bool + => ActorId -> ActorId -> ItemId -> Container -> Bool -> Bool -> [IK.Effect] -> m Bool -itemEffectDisco source target iid recharged periodic effs = do +itemEffectDisco source target iid c recharged periodic effs = do discoKind <- getsServer sdiscoKind item <- getsState $ getItemBody iid case EM.lookup (jkindIx item) discoKind of Just itemKindId -> do - triggered <- itemEffect source target iid recharged periodic effs - -- The effect fires up, so the item gets identified, if seen - -- (the item was at the source actor's position, so his old position - -- is given, since the actor and/or the item may be moved by the effect; - -- we'd need to track not only position of atomic commands and factions, - -- but also which items they relate to, to be fully accurate). - when triggered $ do - postb <- getsState $ getActorBody source - seed <- getsServer $ (EM.! iid) . sitemSeedD - -- Not giving a container to UpdDiscover, because the actor - -- from the container can be dead, etc. - execUpdAtomic $ UpdDiscover (blid postb) (bpos postb) - iid itemKindId seed - return triggered + seed <- getsServer $ (EM.! iid) . sitemSeedD + execUpdAtomic $ UpdDiscover c iid itemKindId seed + itemEffect source target iid recharged periodic effs _ -> assert `failure` (source, target, iid, item) itemEffect :: (MonadAtomic m, MonadServer m) @@ -211,26 +204,26 @@ let execSfx = execSfxAtomic $ SfxEffect (bfid sb) target effect case effect of IK.NoEffect _ -> return False - IK.Hurt nDm -> effectHurt nDm source target False - IK.Burn p -> effectBurn execSfx p source target + IK.Hurt nDm -> effectHurt nDm source target IK.RefillHP + IK.Burn nDm -> effectBurn nDm source target IK.Explode t -> effectExplode execSfx t target IK.RefillHP p -> effectRefillHP False execSfx p source target IK.OverfillHP p -> effectRefillHP True execSfx p source target - IK.RefillCalm p -> effectRefillCalm False execSfx p target - IK.OverfillCalm p -> effectRefillCalm True execSfx p target + IK.RefillCalm p -> effectRefillCalm False execSfx p source target + IK.OverfillCalm p -> effectRefillCalm True execSfx p source target IK.Dominate -> effectDominate recursiveCall source target IK.Impress -> effectImpress execSfx source target IK.CallFriend p -> effectCallFriend p source target - IK.Summon freqs p -> effectSummon recursiveCall freqs p source target - IK.Ascend p -> effectAscend recursiveCall execSfx p target - IK.Escape{} -> effectEscape target + IK.Summon freqs p -> effectSummon freqs p source target + IK.Ascend p -> effectAscend recursiveCall execSfx p source target + IK.Escape{} -> effectEscape source target IK.Paralyze p -> effectParalyze execSfx p target IK.InsertMove p -> effectInsertMove execSfx p target - IK.Teleport p -> effectTeleport execSfx p target + IK.Teleport p -> effectTeleport execSfx p source target IK.CreateItem store grp tim -> effectCreateItem target store grp tim IK.DropItem store grp hit -> effectDropItem execSfx store grp hit target - IK.PolyItem cstore -> effectPolyItem execSfx cstore target - IK.Identify cstore -> effectIdentify iid (bfid sb) cstore target + IK.PolyItem -> effectPolyItem execSfx source target + IK.Identify -> effectIdentify execSfx iid source target IK.SendFlying tmod -> effectSendFlying execSfx tmod source target Nothing IK.PushActor tmod -> @@ -251,18 +244,17 @@ -- Modified by armor. Can, exceptionally, add HP. effectHurt :: (MonadAtomic m, MonadServer m) - => Dice.Dice -> ActorId -> ActorId -> Bool + => Dice.Dice -> ActorId -> ActorId -> (Int -> IK.Effect) -> m Bool -effectHurt nDm source target silent = do +effectHurt nDm source target verboseEffectConstructor = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target hpMax <- sumOrganEqpServer IK.EqpSlotAddMaxHP target n <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm hurtBonus <- armorHurtBonus source target - let block = braced tb - mult = (100 + hurtBonus) * (if block then 50 else 100) + let mult = 100 + hurtBonus rawDeltaHP = - (max oneM -- at least 1 HP taken - (fromIntegral mult * xM n `divUp` (100 * 100))) + (fromIntegral mult * xM n `divUp` 100)) serious = source /= target && not (bproj tb) deltaHP | serious = -- if HP overfull, at least cut back to max HP min rawDeltaHP (xM hpMax - bhp tb) @@ -271,10 +263,12 @@ -- Damage the target. execUpdAtomic $ UpdRefillHP target deltaHP when serious $ halveCalm target - unless silent $ execSfxAtomic $ SfxEffect (bfid sb) target $ + execSfxAtomic $ SfxEffect (bfid sb) target $ if source == target - then IK.RefillHP deltaDiv -- no SfxStrike, so treat as any heal/wound - else IK.Hurt (Dice.intToDice deltaDiv) -- SfxStrike sent, avoid spam + then verboseEffectConstructor deltaDiv + -- no SfxStrike, so treat as any heal/wound + else IK.Hurt (Dice.intToDice (- deltaDiv)) + -- SfxStrike already sent, avoid spam return True armorHurtBonus :: (MonadAtomic m, MonadServer m) @@ -284,11 +278,15 @@ sactiveItems <- activeItemsServer source tactiveItems <- activeItemsServer target sb <- getsState $ getActorBody source - return $! if bproj sb - then sumSlotNoFilter IK.EqpSlotAddHurtRanged sactiveItems - - sumSlotNoFilter IK.EqpSlotAddArmorRanged tactiveItems - else sumSlotNoFilter IK.EqpSlotAddHurtMelee sactiveItems - - sumSlotNoFilter IK.EqpSlotAddArmorMelee tactiveItems + tb <- getsState $ getActorBody target + let itemBonus = + if bproj sb + then sumSlotNoFilter IK.EqpSlotAddHurtRanged sactiveItems + - sumSlotNoFilter IK.EqpSlotAddArmorRanged tactiveItems + else sumSlotNoFilter IK.EqpSlotAddHurtMelee sactiveItems + - sumSlotNoFilter IK.EqpSlotAddArmorMelee tactiveItems + block = braced tb + return $! itemBonus - if block then 50 else 0 halveCalm :: (MonadAtomic m, MonadServer m) => ActorId -> m () @@ -309,12 +307,10 @@ -- Damage from both impact and fire. Modified by armor. effectBurn :: (MonadAtomic m, MonadServer m) - => m () -> Int -> ActorId -> ActorId + => Dice.Dice -> ActorId -> ActorId -> m Bool -effectBurn execSfx power source target = assert (power > 0) $ do - void $ effectHurt (Dice.intToDice power) source target True - execSfx - return True +effectBurn nDm source target = + effectHurt nDm source target (\p -> IK.Burn $ Dice.intToDice (-p)) -- ** Explode @@ -333,8 +329,9 @@ -- from the source. Otherwise, e.g., the points on cardinal -- and diagonal lines from the source would be more common. let fuzz = 2 + (k100 `xor` (itemK * n)) `mod` 9 - k = if itemK >= 8 && n < 8 then 0 - else if n < 8 && n >= 4 then 4 else n + k | itemK >= 8 && n < 8 = 0 + | n < 8 && n >= 4 = 4 + | otherwise = n psAll = [ Point (x - 12) $ y + fuzz , Point (x + 12) $ y - fuzz @@ -363,13 +360,13 @@ forM_ [101..201] $ \k100 -> do bag2 <- getsState $ beqp . getActorBody target let mn2 = EM.lookup iid bag2 - maybe skip (projectN k100) mn2 + maybe (return ()) (projectN k100) mn2 bag3 <- getsState $ beqp . getActorBody target let mn3 = EM.lookup iid bag3 - maybe skip (\kit -> execUpdAtomic - $ UpdLoseItem iid itemBase kit container) mn3 + maybe (return ()) (\kit -> execUpdAtomic + $ UpdLoseItem iid itemBase kit container) mn3 execSfx - return True -- we avoid verifying that at least one projectile got off + return True -- we neglect verifying that at least one projectile got off -- ** RefillHP @@ -381,34 +378,38 @@ hpMax <- sumOrganEqpServer IK.EqpSlotAddMaxHP target let overMax | overfill = xM hpMax * 10 -- arbitrary limit to scumming | otherwise = xM hpMax - serious = overfill && source /= target && not (bproj tb) + serious = not (bproj tb) && source /= target && power > 1 deltaHP | power > 0 = min (xM power) (max 0 $ overMax - bhp tb) - | serious = -- if HP overfull, at least cut back to max HP + | serious = -- if overfull, at least cut back to max min (xM power) (xM hpMax - bhp tb) | otherwise = xM power if deltaHP == 0 then return False else do execUpdAtomic $ UpdRefillHP target deltaHP - when (deltaHP < 0 && serious) $ halveCalm target execSfx + when (deltaHP < 0 && serious) $ halveCalm target return True -- ** RefillCalm effectRefillCalm :: (MonadAtomic m, MonadServer m) - => Bool -> m () -> Int -> ActorId -> m Bool -effectRefillCalm overfill execSfx power target = do + => Bool -> m () -> Int -> ActorId -> ActorId -> m Bool +effectRefillCalm overfill execSfx power source target = do tb <- getsState $ getActorBody target calmMax <- sumOrganEqpServer IK.EqpSlotAddMaxCalm target let overMax | overfill = xM calmMax * 10 -- arbitrary limit to scumming | otherwise = xM calmMax - let deltaCalm = min (xM power) (max 0 $ overMax - bcalm tb) + serious = not (bproj tb) && source /= target && power > 1 + deltaCalm | power > 0 = min (xM power) (max 0 $ overMax - bcalm tb) + | serious = -- if overfull, at least cut back to max + min (xM power) (xM calmMax - bcalm tb) + | otherwise = xM power if deltaCalm == 0 then return False else do - execUpdAtomic $ UpdRefillCalm target deltaCalm execSfx + execUpdAtomic $ UpdRefillCalm target deltaCalm return True -- ** Dominate @@ -420,9 +421,9 @@ effectDominate recursiveCall source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target - if bproj tb then - return False - else if bfid tb == bfid sb then + if bfid tb == bfid sb then + -- Dominate is rather on projectiles than on items, so alternate effect + -- is useful to avoid boredom if domination can't happen. recursiveCall IK.Impress else dominateFidSfx (bfid sb) target @@ -434,15 +435,16 @@ effectImpress execSfx source target = do sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target - if boldfid tb == bfid sb || bproj tb then + if bfidImpressed tb == bfid sb || bproj tb then return False else do execSfx - execUpdAtomic $ UpdOldFidActor target (boldfid tb) (bfid sb) + execUpdAtomic $ UpdFidImpressedActor target (bfidImpressed tb) (bfid sb) return True -- ** CallFriend +-- Note that the Calm expended doesn't depend on the number of actors called. effectCallFriend :: (MonadAtomic m, MonadServer m) => Dice.Dice -> ActorId -> ActorId -> m Bool @@ -451,51 +453,59 @@ Kind.COps{cotile} <- getsState scops power <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm sb <- getsState $ getActorBody source - activeItems <- activeItemsServer source - let legal = source == target - && hpEnough10 sb activeItems -- prevent spam from regen wimps - if not legal then return False + tb <- getsState $ getActorBody target + activeItems <- activeItemsServer target + if not $ hpEnough10 tb activeItems then do + unless (bproj tb) $ do + let subject = partActor tb + verb = "lack enough HP to call aid" + msg = makeSentence [MU.SubjectVerbSg subject verb] + execSfxAtomic $ SfxMsgFid (bfid sb) msg + return False else do - let hpMax = max 1 $ sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems - deltaHP = - xM hpMax `div` 3 - execUpdAtomic $ UpdRefillHP source deltaHP + let deltaHP = - xM 10 + execUpdAtomic $ UpdRefillHP target deltaHP let validTile t = not $ Tile.hasFeature cotile TK.NoActor t - lid = blid sb - ps <- getsState $ nearbyFreePoints validTile (bpos sb) lid - time <- getsState $ getLocalTime lid - recruitActors (take power ps) lid time (bfid sb) + ps <- getsState $ nearbyFreePoints validTile (bpos tb) (blid tb) + time <- getsState $ getLocalTime (blid tb) + -- We call target's friends so that AI monsters that test by throwing + -- don't waste artifacts very valuable for heroes. Heroes should rather + -- not test scrolls by throwing. + recruitActors (take power ps) (blid tb) time (bfid tb) -- ** Summon +-- Note that the Calm expended doesn't depend on the number of actors summoned. effectSummon :: (MonadAtomic m, MonadServer m) - => (IK.Effect -> m Bool) - -> Freqs ItemKind -> Dice.Dice - -> ActorId -> ActorId + => Freqs ItemKind -> Dice.Dice -> ActorId -> ActorId -> m Bool -effectSummon recursiveCall actorFreq nDm source target = do +effectSummon actorFreq nDm source target = do -- Obvious effect, nothing announced. Kind.COps{cotile} <- getsState scops power <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm sb <- getsState $ getActorBody source - activeItems <- activeItemsServer source - let legal = source == target && (bproj sb || calmEnough10 sb activeItems) - if not legal then return False + tb <- getsState $ getActorBody target + activeItems <- activeItemsServer target + if not $ calmEnough10 tb activeItems then do + unless (bproj tb) $ do + let subject = partActor tb + verb = "lack enough Calm to summon" + msg = makeSentence [MU.SubjectVerbSg subject verb] + execSfxAtomic $ SfxMsgFid (bfid sb) msg + return False else do - let calmMax = max 1 $ sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems - deltaCalm = - xM calmMax `div` 3 - unless (bproj sb) $ execUpdAtomic $ UpdRefillCalm source deltaCalm + let deltaCalm = - xM 10 + unless (bproj tb) $ execUpdAtomic $ UpdRefillCalm target deltaCalm let validTile t = not $ Tile.hasFeature cotile TK.NoActor t - ps <- getsState $ nearbyFreePoints validTile (bpos sb) (blid sb) - localTime <- getsState $ getLocalTime (blid sb) + ps <- getsState $ nearbyFreePoints validTile (bpos tb) (blid tb) + localTime <- getsState $ getLocalTime (blid tb) -- Make sure summoned actors start acting after the summoner. - let sourceTime = timeShift localTime $ ticksPerMeter $ bspeed sb activeItems - afterTime = timeShift sourceTime $ Delta timeClip + let targetTime = timeShift localTime $ ticksPerMeter $ bspeed tb activeItems + afterTime = timeShift targetTime $ Delta timeClip bs <- forM (take power ps) $ \p -> do - maid <- addAnyActor actorFreq (blid sb) afterTime (Just p) + maid <- addAnyActor actorFreq (blid tb) afterTime (Just p) case maid of - Nothing -> - -- Don't make this item useless. - recursiveCall (IK.CallFriend 1) + Nothing -> return False -- actorFreq is null; content writers... Just aid -> do b <- getsState $ getActorBody aid mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD @@ -510,25 +520,31 @@ -- Note that projectiles can be teleported, too, for extra fun. effectAscend :: (MonadAtomic m, MonadServer m) => (IK.Effect -> m Bool) - -> m () -> Int -> ActorId + -> m () -> Int -> ActorId -> ActorId -> m Bool -effectAscend recursiveCall execSfx k aid = do - b1 <- getsState $ getActorBody aid +effectAscend recursiveCall execSfx k source target = do + b1 <- getsState $ getActorBody target ais1 <- getsState $ getCarriedAssocs b1 let lid1 = blid b1 pos1 = bpos b1 (lid2, pos2) <- getsState $ whereTo lid1 pos1 k . sdungeon - if lid2 == lid1 && pos2 == pos1 then do - execSfxAtomic $ SfxMsgFid (bfid b1) "No more levels in this direction." + sb <- getsState $ getActorBody source + if braced b1 then do + execSfxAtomic $ SfxMsgFid (bfid sb) + "Braced actors are immune to translocation." + return False + else if lid2 == lid1 && pos2 == pos1 then do + execSfxAtomic $ SfxMsgFid (bfid sb) "No more levels in this direction." + -- We keep it useful even in shallow dungeons. recursiveCall $ IK.Teleport 30 -- powerful teleport else do - let switch1 = void $ switchLevels1 ((aid, b1), ais1) + let switch1 = void $ switchLevels1 ((target, b1), ais1) switch2 = do -- Make the initiator of the stair move the leader, -- to let him clear the stairs for others to follow. - let mlead = Just aid + let mlead = Just target -- Move the actor to where the inhabitants were, if any. - switchLevels2 lid2 pos2 ((aid, b1), ais1) mlead + switchLevels2 lid2 pos2 ((target, b1), ais1) mlead -- Verify only one non-projectile actor on every tile. !_ <- getsState $ posToActors pos1 lid1 -- assertion is inside !_ <- getsState $ posToActors pos2 lid2 -- assertion is inside @@ -590,7 +606,7 @@ switchLevels2 lidNew posNew ((aid, bOld), ais) mlead = do let lidOld = blid bOld side = bfid bOld - assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) skip + let !_A = assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) () -- Sync the actor time with the level time. timeOld <- getsState $ getLocalTime lidOld timeLastActive <- getsState $ getLocalTime lidNew @@ -602,7 +618,7 @@ computeNewTimeout :: ItemQuant -> ItemQuant computeNewTimeout (k, it) = (k, map shiftByDelta it) setTimeout :: ItemBag -> ItemBag - setTimeout bag = EM.map computeNewTimeout bag + setTimeout = EM.map computeNewTimeout bNew = bOld { blid = lidNew , btime = shiftByDelta $ btime bOld , bpos = posNew @@ -622,16 +638,21 @@ -- ** Escape -- | The faction leaves the dungeon. -effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> m Bool -effectEscape target = do +effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m Bool +effectEscape source target = do -- Obvious effect, nothing announced. + sb <- getsState $ getActorBody source b <- getsState $ getActorBody target let fid = bfid b fact <- getsState $ (EM.! fid) . sfactionD - if not (fcanEscape $ gplayer fact) || bproj b then + if bproj b then return False + else if not (fcanEscape $ gplayer fact) then do + execSfxAtomic $ SfxMsgFid (bfid sb) + "This faction doesn't want to escape outside." + return False else do - deduceQuits b $ Status Escape (fromEnum $ blid b) Nothing + deduceQuits fid Nothing $ Status Escape (fromEnum $ blid b) Nothing return True -- ** Paralyze @@ -672,10 +693,11 @@ -- | Teleport the target actor. -- Note that projectiles can be teleported, too, for extra fun. effectTeleport :: (MonadAtomic m, MonadServer m) - => m () -> Dice.Dice -> ActorId -> m Bool -effectTeleport execSfx nDm target = do + => m () -> Dice.Dice -> ActorId -> ActorId -> m Bool +effectTeleport execSfx nDm source target = do Kind.COps{cotile} <- getsState scops range <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm + sb <- getsState $ getActorBody source b <- getsState $ getActorBody target Level{ltile} <- getLevel (blid b) as <- getsState $ actorList (const True) (blid b) @@ -689,15 +711,20 @@ && (not (dMinMax 9 p) -- don't loop, very rare || not (Tile.hasFeature cotile TK.NoActor t) && unoccupied as p)) - [ dist $ 1 + [ dist 1 , dist $ 1 + range `div` 9 , dist $ 1 + range `div` 7 , dist $ 1 + range `div` 5 - , dist $ 5 - , dist $ 7 + , dist 5 + , dist 7 ] - if not (dMinMax 9 tpos) then - return False -- very rare + if braced b then do + execSfxAtomic $ SfxMsgFid (bfid sb) + "Braced actors are immune to translocation." + return False + else if not (dMinMax 9 tpos) then do -- very rare + execSfxAtomic $ SfxMsgFid (bfid sb) "Translocation not possible." + return False else do execUpdAtomic $ UpdMoveActor target spos tpos execSfx @@ -705,6 +732,10 @@ -- ** CreateItem +-- TODO: if the items is created not on the ground, perhaps it should +-- be IDed, so that there are no rings with unkown max Calm bonus +-- leading to attempts to do illegal actions (which the server then catches). +-- This is in analogy to picking item from the ground, whereas it's IDed. effectCreateItem :: (MonadAtomic m, MonadServer m) => ActorId -> CStore -> GroupName ItemKind -> IK.TimerDice -> m Bool @@ -714,21 +745,21 @@ IK.TimerNone -> return $ Delta timeZero IK.TimerGameTurn nDm -> do k <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm - assert (k >= 0) skip + let !_A = assert (k >= 0) () return $! timeDeltaScale (Delta timeTurn) k IK.TimerActorTurn nDm -> do k <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm - assert (k >= 0) skip + let !_A = assert (k >= 0) () activeItems <- activeItemsServer target let actorTurn = ticksPerMeter $ bspeed tb activeItems return $! timeDeltaScale actorTurn k let c = CActor target store bagBefore <- getsState $ getCBag c let litemFreq = [(grp, 1)] - m4 <- rollItem (blid tb) litemFreq - let (itemKnown, itemFull, seed, _) = case m4 of - Nothing -> assert `failure` (blid tb, litemFreq, c) - Just i4 -> i4 + -- Power depth of new items unaffected by number of spawned actors. + m5 <- rollItem 0 (blid tb) litemFreq + let (itemKnown, itemFull, _, seed, _) = + fromMaybe (assert `failure` (blid tb, litemFreq, c)) m5 itemRev <- getsServer sitemRev let mquant = case HM.lookup itemKnown itemRev of Nothing -> Nothing @@ -744,15 +775,14 @@ _ -> do -- Multiple such items, so it's a periodic poison, etc., so just stack, -- or no such items at all, so create some. - iid <- registerItem (itemBase itemFull) itemKnown seed - (itemK itemFull) c True + iid <- registerItem itemFull itemKnown seed (itemK itemFull) c True unless (tim == IK.TimerNone) $ do bagAfter <- getsState $ getCBag c localTime <- getsState $ getLocalTime (blid tb) let newTimer = localTime `timeShift` delta - (afterK, afterIt) = case iid `EM.lookup` bagAfter of - Nothing -> assert `failure` (iid, bagAfter, c) - Just kit -> kit + (afterK, afterIt) = + fromMaybe (assert `failure` (iid, bagAfter, c)) + (iid `EM.lookup` bagAfter) newIt = replicate afterK newTimer when (afterIt /= newIt) $ execUpdAtomic $ UpdTimeItem iid c afterIt newIt @@ -782,7 +812,7 @@ if null is then return False else do - mapM_ (\(iid, kit) -> dropCStoreItem store target b hit iid kit) is + mapM_ (uncurry (dropCStoreItem store target b hit)) is unless (store == COrgan) execSfx return True @@ -815,76 +845,90 @@ -- ** PolyItem +-- TODO: ask player for an item effectPolyItem :: (MonadAtomic m, MonadServer m) - => m () -> CStore -> ActorId -> m Bool -effectPolyItem execSfx cstore target = do + => m () -> ActorId -> ActorId -> m Bool +effectPolyItem execSfx source target = do + sb <- getsState $ getActorBody source + let cstore = CGround allAssocs <- fullAssocsServer target [cstore] case allAssocs of [] -> do - tb <- getsState $ getActorBody target - execSfxAtomic $ SfxMsgFid (bfid tb) $ + execSfxAtomic $ SfxMsgFid (bfid sb) $ "The purpose of repurpose cannot be availed without an item" - <+> ppCStore cstore <> "." - -- TODO: identify the scroll, but don't use up. - return True + <+> ppCStoreIn cstore <> "." + return False (iid, itemFull@ItemFull{..}) : _ -> case itemDisco of - Just ItemDisco{itemKind} -> do + Just ItemDisco{..} -> do + discoEffect <- getsServer sdiscoEffect let maxCount = Dice.maxDice $ IK.icount itemKind - if itemK >= maxCount - then do + aspects = jaspects $ discoEffect EM.! iid + if itemK < maxCount then do + execSfxAtomic $ SfxMsgFid (bfid sb) $ + "The purpose of repurpose is served by" <+> tshow maxCount + <+> "pieces of this item, not by" <+> tshow itemK <> "." + return False + else if IK.Unique `elem` aspects then do + execSfxAtomic $ SfxMsgFid (bfid sb) $ + "Unique items can't be repurposed." + return False + else do let c = CActor target cstore kit = (maxCount, take maxCount itemTimer) + identifyIid execSfx iid c itemKindId execUpdAtomic $ UpdDestroyItem iid itemBase kit c - execSfx effectCreateItem target cstore "useful" IK.TimerNone - else do - tb <- getsState $ getActorBody target - execSfxAtomic $ SfxMsgFid (bfid tb) $ - "The purpose of repurpose is served by" <+> tshow maxCount - <+> "pieces of this item, not by" <+> tshow itemK <> "." - -- TODO: identify the scroll, but don't use up. - return True - _ -> assert `failure` (cstore, target, iid, itemFull) + _ -> assert `failure` (target, iid, itemFull) -- ** Identify -- TODO: ask player for an item, because server doesn't know which -- is already identified, it only knows which cannot ever be. +-- Perhaps refill Calm only when id successfull and scroll consumed, +-- id the scroll anyway. Explain the Calm gain: "your most pressing +-- existential concerns are answered scientifitically". effectIdentify :: (MonadAtomic m, MonadServer m) - => ItemId -> FactionId -> CStore -> ActorId -> m Bool -effectIdentify iidId fid storeInitial target = do + => m () -> ItemId -> ActorId -> ActorId -> m Bool +effectIdentify execSfx iidId source target = do + sb <- getsState $ getActorBody source let tryFull store as = case as of - [] -> return False - (iid, itemFull@ItemFull{..}) : rest -> case itemDisco of - _ | iid == iidId -> tryFull store rest -- don't id itself - Just ItemDisco{..} -> do - -- TODO: use this (but faster, via traversing effects with 999) - -- also to prevent sending any other UpdDiscover. - let ided = IK.Identified `elem` IK.ifeature itemKind - itemSecret = itemNoAE itemFull - c = CActor target store - statsObvious = textAllAE False c itemFull - == textAllAE False c itemSecret - if ided && statsObvious - then tryFull store rest - else do - let effect = IK.Identify store -- the real store, not initial - execSfxAtomic $ SfxEffect fid target effect -- a cheat - tb <- getsState $ getActorBody target - seed <- getsServer $ (EM.! iid) . sitemSeedD - execUpdAtomic $ - UpdDiscover (blid tb) (bpos tb) iid itemKindId seed - return True - _ -> assert `failure` (store, target, iid, itemFull) + -- TODO: identify the scroll, but don't use up. + [] -> do + let (tIn, t) = ppCStore store + msg = "Nothing to identify" <+> tIn <+> t <> "." + execSfxAtomic $ SfxMsgFid (bfid sb) msg + return False + (iid, _) : rest | iid == iidId -> tryFull store rest -- don't id itself + (iid, itemFull@ItemFull{itemDisco=Just ItemDisco{..}}) : rest -> do + -- TODO: use this (but faster, via traversing effects with 999?) + -- also to prevent sending any other UpdDiscover. + let ided = IK.Identified `elem` IK.ifeature itemKind + itemSecret = itemNoAE itemFull + statsObvious = textAllAE 7 False store itemFull + == textAllAE 7 False store itemSecret + if ided && statsObvious + then tryFull store rest + else do + let c = CActor target store + identifyIid execSfx iid c itemKindId + return True + _ -> assert `failure` (store, as) tryStore stores = case stores of [] -> return False store : rest -> do allAssocs <- fullAssocsServer target [store] go <- tryFull store allAssocs if go then return True else tryStore rest - storesSorted = storeInitial : delete storeInitial [CGround, CInv, CEqp] - tryStore storesSorted + tryStore [CGround] +identifyIid :: (MonadAtomic m, MonadServer m) + => m () -> ItemId -> Container -> Kind.Id ItemKind + -> m () +identifyIid execSfx iid c itemKindId = do + execSfx + seed <- getsServer $ (EM.! iid) . sitemSeedD + execUpdAtomic $ UpdDiscover c iid itemKindId seed + -- ** SendFlying -- | Shend the target actor flying like a projectile. The arguments correspond @@ -899,11 +943,16 @@ effectSendFlying execSfx IK.ThrowMod{..} source target modePush = do v <- sendFlyingVector source target modePush Kind.COps{cotile} <- getsState scops + sb <- getsState $ getActorBody source tb <- getsState $ getActorBody target lvl@Level{lxsize, lysize} <- getLevel (blid tb) let eps = 0 fpos = bpos tb `shift` v - case bla lxsize lysize eps (bpos tb) fpos of + if braced tb then do + execSfxAtomic $ SfxMsgFid (bfid sb) + "Braced actors are immune to translocation." + return False + else case bla lxsize lysize eps (bpos tb) fpos of Nothing -> assert `failure` (fpos, tb) Just [] -> assert `failure` "projecting from the edge of level" `twith` (fpos, tb) @@ -918,16 +967,26 @@ (trajectory, (speed, _)) = computeTrajectory weight throwVelocity throwLinger path ts = Just (trajectory, speed) - unless (btrajectory tb == ts) $ - execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts - execSfx - return True + if null trajectory || btrajectory tb == ts + || throwVelocity <= 0 || throwLinger <= 0 + then return False -- e.g., actor is too heavy; OK + else do + execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts + -- Give the actor one extra turn and also let the push start ASAP. + -- So, if the push lasts one (his) turn, he will not lose + -- any turn of movement (but he may need to retrace the push). + activeItems <- activeItemsServer target + let tpm = ticksPerMeter $ bspeed tb activeItems + delta = timeDeltaScale tpm (-1) + execUpdAtomic $ UpdAgeActor target delta + execSfx + return True sendFlyingVector :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> Maybe Bool -> m Vector sendFlyingVector source target modePush = do sb <- getsState $ getActorBody source - if source == target then do + if source == target then if boldpos sb == bpos sb then rndToAction $ do z <- randomR (-10, 10) oneOf [Vector 10 z, Vector (-10) z, Vector z 10, Vector z (-10)] @@ -956,12 +1015,13 @@ effectDropBestWeapon :: (MonadAtomic m, MonadServer m) => m () -> ActorId -> m Bool effectDropBestWeapon execSfx target = do + tb <- getsState $ getActorBody target allAssocs <- fullAssocsServer target [CEqp] - case strongestSlotNoFilter IK.EqpSlotWeapon allAssocs of + localTime <- getsState $ getLocalTime (blid tb) + case strongestMelee False localTime allAssocs of (_, (iid, _)) : _ -> do - b <- getsState $ getActorBody target - let kit = beqp b EM.! iid - dropCStoreItem CEqp target b False iid kit + let kit = beqp tb EM.! iid + dropCStoreItem CEqp target tb False iid kit execSfx return True [] -> @@ -969,13 +1029,13 @@ -- ** ActivateInv --- | Activate all activable items with the given symbol +-- | Activate all items with the given symbol -- 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 execSfx target symbol = do +effectActivateInv execSfx target symbol = effectTransformEqp execSfx target symbol CInv $ \iid _ -> applyItem target iid CInv @@ -1018,8 +1078,14 @@ -> [IK.Effect] -> m Bool effectOneOf recursiveCall l = do - ef <- rndToAction $ oneOf l - recursiveCall ef + let call1 = do + ef <- rndToAction $ oneOf l + recursiveCall ef + call99 = replicate 99 call1 + f callNext result = do + b <- result + if b then return True else callNext + foldr f (return False) call99 -- ** Recharging @@ -1040,6 +1106,6 @@ effectTemporary execSfx source iid = do bag <- getsState $ getCBag $ CActor source COrgan case iid `EM.lookup` bag of - Just _ -> skip -- still some copies left of a multi-copy tmp item + Just _ -> return () -- still some copies left of a multi-copy tmp item Nothing -> execSfx -- last copy just destroyed return True diff --git a/Game/LambdaHack/Server/HandleRequestServer.hs b/Game/LambdaHack/Server/HandleRequestServer.hs --- a/Game/LambdaHack/Server/HandleRequestServer.hs +++ b/Game/LambdaHack/Server/HandleRequestServer.hs @@ -12,6 +12,7 @@ ( handleRequestAI, handleRequestUI, reqMove ) where +import Control.Applicative import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM @@ -54,7 +55,7 @@ ReqAILeader aidNew mtgtNew cmd2 -> do switchLeader fid aidNew mtgtNew handleRequestAI fid aidNew cmd2 - ReqAIPong -> return (aid, skip) + ReqAIPong -> return (aid, return ()) -- | The semantics of server commands. The resulting actor id -- is of the actor that carried out the request. @Nothing@ means @@ -75,7 +76,7 @@ ReqUIGameSave -> return (Nothing, reqGameSave) ReqUITactic toT -> return (Nothing, reqTactic fid toT) ReqUIAutomate -> return (Nothing, reqAutomate fid) - ReqUIPong _ -> return (Nothing, skip) + ReqUIPong _ -> return (Nothing, return ()) handleRequestTimed :: (MonadAtomic m, MonadServer m) => ActorId -> RequestTimed a -> m () @@ -85,8 +86,7 @@ ReqDisplace target -> reqDisplace aid target ReqAlter tpos mfeat -> reqAlter aid tpos mfeat ReqWait -> reqWait aid - ReqMoveItem iid k fromCStore toCStore -> - reqMoveItem aid iid k fromCStore toCStore + ReqMoveItems l -> reqMoveItems aid l ReqProject p eps iid cstore -> reqProject aid p eps iid cstore ReqApply iid cstore -> reqApply aid iid cstore ReqTrigger mfeat -> reqTrigger aid mfeat @@ -98,12 +98,12 @@ bPre <- getsState $ getActorBody aidNew let mleader = gleader fact actorChanged = fmap fst mleader /= Just aidNew - assert (Just (aidNew, mtgtNew) /= mleader - && not (bproj bPre) - `blame` (aidNew, mtgtNew, bPre, fid, fact)) skip - assert (bfid bPre == fid - `blame` "client tries to move other faction actors" - `twith` (aidNew, mtgtNew, bPre, fid, fact)) skip + let !_A = assert (Just (aidNew, mtgtNew) /= mleader + && not (bproj bPre) + `blame` (aidNew, mtgtNew, bPre, fid, fact)) () + let !_A = assert (bfid bPre == fid + `blame` "client tries to move other faction actors" + `twith` (aidNew, mtgtNew, bPre, fid, fact)) () let (autoDun, autoLvl) = autoDungeonLevel fact arena <- case mleader of Nothing -> return $! blid bPre @@ -121,22 +121,27 @@ -- TODO: let only some actors/items leave smell, e.g., a Smelly Hide Armour -- and then remove the efficiency hack below that only heroes leave smell -- | Add a smell trace for the actor to the level. For now, only heroes --- leave smell. +-- leave smell. If smell already there and the actor can smell, remove smell. addSmell :: (MonadAtomic m, MonadServer m) => ActorId -> m () addSmell aid = do b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD smellRadius <- sumOrganEqpServer IK.EqpSlotAddSmell aid - -- TODO: right now only humans leave smell and content should not - -- give humans the ability to smell (dominated monsters are rare enough). - -- In the future smells should be marked by the faction that left them - -- and actors shold only follow enemy smells. - unless (bproj b || not (fhasGender $ gplayer fact) || smellRadius > 0) $ do + let dumbMonster = not (fhasGender $ gplayer fact) && smellRadius <= 0 + unless (bproj b || dumbMonster) $ do + -- TODO: right now only humans leave smell and content should not + -- give humans the ability to smell (dominated monsters are rare enough). + -- In the future smells should be marked by the faction that left them + -- and actors shold only follow enemy smells. time <- getsState $ getLocalTime $ blid b lvl <- getLevel $ blid b let oldS = EM.lookup (bpos b) . lsmell $ lvl newTime = timeShift time smellTimeout - execUpdAtomic $ UpdAlterSmell (blid b) (bpos b) oldS (Just newTime) + newS = if smellRadius > 0 + then Nothing -- smelling monster or hero + else Just newTime -- hero + when (oldS /= newS) $ + execUpdAtomic $ UpdAlterSmell (blid b) (bpos b) oldS newS -- | Actor moves or attacks. -- Note that client may not be able to see an invisible monster @@ -195,14 +200,12 @@ tfid = bfid tb sfact <- getsState $ (EM.! sfid) . sfactionD hurtBonus <- armorHurtBonus source target - let isFightImpaired = hurtBonus <= -10 - block = braced tb - hitA = if block && isFightImpaired - then HitBlock 2 - else if block || isFightImpaired - then HitBlock 1 - else HitClear - execSfxAtomic $ SfxStrike source target iid hitA + let hitA | hurtBonus <= -50 -- e.g., braced and no hit bonus + = HitBlock 2 + | hurtBonus <= -10 -- low bonus vs armor + = HitBlock 1 + | otherwise = HitClear + execSfxAtomic $ SfxStrike source target iid cstore hitA -- Deduct a hitpoint for a pierce of a projectile -- or due to a hurled actor colliding with another or a wall. case btrajectory sb of @@ -249,7 +252,7 @@ case mweapon of Nothing -> reqWait source Just (wp, cstore) -> reqMelee source target wp cstore - -- DisplaceDying, DisplaceSupported + -- DisplaceDying, etc. else do let lid = blid sb lvl <- getLevel lid @@ -260,10 +263,8 @@ [] -> assert `failure` (source, sb, target, tb) [_] -> do execUpdAtomic $ UpdDisplaceActor source target - addSmell source - addSmell target _ -> execFailure source req DisplaceProjectiles - else do + else -- Client foolishly tries to displace an actor without access. execFailure source req DisplaceAccess @@ -288,8 +289,8 @@ freshClientTile = hideTile cops lvl tpos changeTo tgroup = do -- No @SfxAlter@, because the effect is obvious (e.g., opened door). - toTile <- rndToAction $ fmap (fromMaybe $ assert `failure` tgroup) - $ opick tgroup (const True) + toTile <- rndToAction $ (fromMaybe $ assert `failure` tgroup) + <$> opick tgroup (const True) unless (toTile == serverTile) $ do execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile case (Tile.isExplorable cotile serverTile, @@ -312,14 +313,14 @@ if null groupsToAlterTo && serverTile == freshClientTile then -- Neither searching nor altering possible; silly client. execFailure source req AlterNothing - else do + else if EM.notMember tpos $ lfloor lvl then if unoccupied as tpos then do - when (serverTile /= freshClientTile) $ do + when (serverTile /= freshClientTile) $ -- Search, in case some actors (of other factions?) -- don't know this tile. execUpdAtomic $ UpdSearchTile source tpos freshClientTile serverTile - maybe skip changeTo $ listToMaybe groupsToAlterTo + maybe (return ()) changeTo $ listToMaybe groupsToAlterTo -- TODO: pick another, if the first one void -- Perform an effect, if any permitted. void $ triggerEffect source tpos feats @@ -334,53 +335,62 @@ reqWait :: MonadAtomic m => ActorId -> m () reqWait _ = return () --- * ReqMoveItem +-- * ReqMoveItems -reqMoveItem :: (MonadAtomic m, MonadServer m) - => ActorId -> ItemId -> Int -> CStore -> CStore -> m () -reqMoveItem aid iid k fromCStore toCStore = do +reqMoveItems :: (MonadAtomic m, MonadServer m) + => ActorId -> [(ItemId, Int, CStore, CStore)] -> m () +reqMoveItems aid l = do b <- getsState $ getActorBody aid activeItems <- activeItemsServer aid + -- Server accepts item movement based on calm at the start, not end + -- or in the middle, to avoid interrupted or partially ignored commands. + let calmE = calmEnough b activeItems + mapM_ (reqMoveItem aid calmE) l + +reqMoveItem :: (MonadAtomic m, MonadServer m) + => ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m () +reqMoveItem aid calmE (iid, k, fromCStore, toCStore) = do + b <- getsState $ getActorBody aid let fromC = CActor aid fromCStore toC = CActor aid toCStore + req = ReqMoveItems [(iid, k, fromCStore, toCStore)] bagBefore <- getsState $ getCBag toC - let moveItem = do - when (fromCStore == CGround) $ do - seed <- getsServer $ (EM.! iid) . sitemSeedD - execUpdAtomic $ UpdDiscoverSeed (blid b) (bpos b) iid seed - upds <- generalMoveItem iid k fromC toC - mapM_ execUpdAtomic upds - req = ReqMoveItem iid k fromCStore toCStore if k < 1 || fromCStore == toCStore then execFailure aid req ItemNothing else if toCStore == CEqp && eqpOverfull b k then execFailure aid req EqpOverfull - else if fromCStore /= CSha && toCStore /= CSha then moveItem + else if (fromCStore == CSha || toCStore == CSha) + && not calmE then execFailure aid req ItemNotCalm else do - if calmEnough b activeItems then moveItem - else execFailure aid req ItemNotCalm - -- Reset timeout for equipped periodic items. - when (toCStore `elem` [CEqp, COrgan] - && fromCStore `notElem` [CEqp, COrgan]) $ do - localTime <- getsState $ getLocalTime (blid b) - discoEffect <- getsServer sdiscoEffect - mrndTimeout <- rndToAction $ computeRndTimeout localTime discoEffect iid - let beforeIt = case iid `EM.lookup` bagBefore of - Nothing -> [] -- no such items before move - Just (_, it2) -> it2 - -- The moved item set (not the whole stack) has its timeout - -- reset to a random value between timeout and twice timeout. - -- This prevents micromanagement via swapping items in and out of eqp - -- and via exact prediction of first timeout after equip. - case mrndTimeout of - Just rndT -> do - bagAfter <- getsState $ getCBag toC - let afterIt = case iid `EM.lookup` bagAfter of - Nothing -> assert `failure` (iid, bagAfter, toC) - Just (_, it2) -> it2 - resetIt = beforeIt ++ replicate k rndT - when (afterIt /= resetIt) $ - execUpdAtomic $ UpdTimeItem iid toC afterIt resetIt - Nothing -> return () -- no Periodic or Timeout aspect; don't touch + when (fromCStore == CGround) $ do + seed <- getsServer $ (EM.! iid) . sitemSeedD + execUpdAtomic $ UpdDiscoverSeed fromC iid seed + upds <- generalMoveItem iid k fromC toC + mapM_ execUpdAtomic upds + -- Reset timeout for equipped periodic items. + when (toCStore `elem` [CEqp, COrgan] + && fromCStore `notElem` [CEqp, COrgan]) $ do + localTime <- getsState $ getLocalTime (blid b) + discoEffect <- getsServer sdiscoEffect + -- The first recharging period after pick up is random, + -- between 1 and 2 standard timeouts of the item. + mrndTimeout <- rndToAction $ computeRndTimeout localTime discoEffect iid + let beforeIt = case iid `EM.lookup` bagBefore of + Nothing -> [] -- no such items before move + Just (_, it2) -> it2 + -- The moved item set (not the whole stack) has its timeout + -- reset to a random value between timeout and twice timeout. + -- This prevents micromanagement via swapping items in and out of eqp + -- and via exact prediction of first timeout after equip. + case mrndTimeout of + Just rndT -> do + bagAfter <- getsState $ getCBag toC + let afterIt = case iid `EM.lookup` bagAfter of + Nothing -> assert `failure` (iid, bagAfter, toC) + Just (_, it2) -> it2 + resetIt = beforeIt ++ replicate k rndT + when (afterIt /= resetIt) $ + execUpdAtomic $ UpdTimeItem iid toC afterIt resetIt + Nothing -> return () -- no Periodic or Timeout aspect; don't touch computeRndTimeout :: Time -> DiscoveryEffect -> ItemId -> Rnd (Maybe Time) computeRndTimeout localTime discoEffect iid = do @@ -388,7 +398,7 @@ timeoutAspect (IK.Timeout t) = Just t timeoutAspect _ = Nothing case EM.lookup iid discoEffect of - Just ItemAspectEffect{jaspects} -> do + Just ItemAspectEffect{jaspects} -> case mapMaybe timeoutAspect jaspects of [t] | IK.Periodic `elem` jaspects -> do rndT <- randomR (0, t) @@ -406,10 +416,10 @@ -> ItemId -- ^ the item to be projected -> CStore -- ^ whether the items comes from floor or inventory -> m () -reqProject source tpxy eps iid cstore = assert (cstore /= CSha) $ do +reqProject source tpxy eps iid cstore = do mfail <- projectFail source tpxy eps iid cstore False let req = ReqProject tpxy eps iid cstore - maybe skip (execFailure source req) mfail + maybe (return ()) (execFailure source req) mfail -- * ReqApply @@ -418,7 +428,7 @@ -> ItemId -- ^ the item to be applied -> CStore -- ^ the location of the item -> m () -reqApply aid iid cstore = assert (cstore /= CSha) $ do +reqApply aid iid cstore = do let req = ReqApply iid cstore bag <- getsState $ getActorBag aid cstore case EM.lookup iid bag of @@ -428,9 +438,10 @@ b <- getsState $ getActorBody aid activeItems <- activeItemsServer aid actorSk <- actorSkillsServer aid + localTime <- getsState $ getLocalTime (blid b) let skill = EM.findWithDefault 0 Ability.AbProject actorSk itemFull = itemToF iid kit - legal = permittedApply " " skill itemFull b activeItems + legal = permittedApply " " localTime skill itemFull b activeItems case legal of Left reqFail -> execFailure aid req reqFail Right _ -> applyItem aid iid cstore @@ -471,7 +482,8 @@ -- so that they are available in the first game too, -- not only in subsequent, restarted, games. reqGameRestart :: (MonadAtomic m, MonadServer m) - => ActorId -> GroupName ModeKind -> Int -> [(Int, (Text, Text))] -> m () + => ActorId -> GroupName ModeKind -> Int -> [(Int, (Text, Text))] + -> m () reqGameRestart aid groupName d configHeroNames = do modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d 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 @@ -2,17 +2,19 @@ -- | Server types and operations for items that don't involve server state -- nor our custom monads. module Game.LambdaHack.Server.ItemRev - ( ItemRev, buildItem, newItem + ( ItemRev, buildItem, newItem, UniqueSet -- * Item discovery types , DiscoveryKindRev, serverDiscos, ItemSeedDict -- * The @FlavourMap@ type , FlavourMap, emptyFlavourMap, dungeonFlavourMap ) where +import Control.Applicative import Control.Exception.Assert.Sugar import Control.Monad import Data.Binary import qualified Data.EnumMap.Strict as EM +import qualified Data.EnumSet as ES import qualified Data.HashMap.Strict as HM import qualified Data.Ix as Ix import Data.List @@ -34,6 +36,8 @@ -- | The map of item ids to item seeds, needed for item creation. type ItemSeedDict = EM.EnumMap ItemId ItemSeed +type UniqueSet = ES.EnumSet (Kind.Id ItemKind) + serverDiscos :: Kind.COps -> Rnd (DiscoveryKind, DiscoveryKindRev) serverDiscos Kind.COps{coitem=Kind.Ops{obounds, ofoldrWithKey}} = do let ixs = map toEnum $ take (Ix.rangeSize obounds) [0..] @@ -41,7 +45,7 @@ shuffle [] = return [] shuffle l = do x <- oneOf l - fmap (x :) $ shuffle (delete x l) + (x :) <$> shuffle (delete x l) shuffled <- shuffle ixs let f ik _ (ikMap, ikRev, ix : rest) = (EM.insert ix ik ikMap, EM.insert ik ix ikRev, rest) @@ -52,7 +56,8 @@ return (discoS, discoRev) -- | Build an item with the given stats. -buildItem :: FlavourMap -> DiscoveryKindRev -> Kind.Id ItemKind -> ItemKind -> LevelId +buildItem :: FlavourMap -> DiscoveryKindRev -> Kind.Id ItemKind -> ItemKind + -> LevelId -> Item buildItem (FlavourMap flavour) discoRev ikChosen kind jlid = let jkindIx = discoRev EM.! ikChosen @@ -67,41 +72,58 @@ in Item{..} -- | Generate an item based on level. -newItem :: Kind.COps -> FlavourMap -> DiscoveryKindRev - -> Freqs ItemKind -> LevelId -> AbsDepth -> AbsDepth - -> Rnd (Maybe (ItemKnown, ItemFull, ItemSeed, GroupName ItemKind)) +newItem :: Kind.COps -> FlavourMap -> DiscoveryKindRev -> UniqueSet + -> Freqs ItemKind -> Int -> LevelId -> AbsDepth -> AbsDepth + -> Rnd (Maybe ( ItemKnown, ItemFull, ItemDisco + , ItemSeed, GroupName ItemKind )) newItem Kind.COps{coitem=Kind.Ops{ofoldrGroup}} - flavour discoRev itemFreq jlid - ldepth@(AbsDepth ld) totalDepth@(AbsDepth depth) = do - let findInterval x1y1 [] = (x1y1, (11, 0)) - findInterval x1y1 ((x, y) : rest) = - if ld * 10 <= x * depth + flavour discoRev uniqueSet itemFreq lvlSpawned jlid + ldepth@(AbsDepth ldAbs) totalDepth@(AbsDepth depth) = do + -- Effective generation depth of actors (not items) increases with spawns. + let scaledDepth = ldAbs * 10 `div` depth + numSpawnedCoeff = lvlSpawned `div` 2 + ldSpawned = max ldAbs -- the first fast spawns are of the nominal level + $ min depth + $ ldAbs + numSpawnedCoeff - scaledDepth + findInterval _ x1y1 [] = (x1y1, (11, 0)) + findInterval ld x1y1 ((x, y) : rest) = + if fromIntegral ld * 10 <= x * fromIntegral depth then (x1y1, (x, y)) - else findInterval (x, y) rest - linearInterpolation dataset = - -- We assume @dataset@ is sorted and between 1 and 10 inclusive. - let ((x1, y1), (x2, y2)) = findInterval (0, 0) dataset - in y1 + (y2 - y1) * (ld * 10 - x1 * depth) - `divUp` ((x2 - x1) * depth) + else findInterval ld (x, y) rest + linearInterpolation ld dataset = + -- We assume @dataset@ is sorted and between 0 and 10. + let ((x1, y1), (x2, y2)) = findInterval ld (0, 0) dataset + in ceiling + $ fromIntegral y1 + + fromIntegral (y2 - y1) + * (fromIntegral ld * 10 - x1 * fromIntegral depth) + / ((x2 - x1) * fromIntegral depth) + f _ _ _ ik _ acc | ik `ES.member` uniqueSet = acc f itemGroup q p ik kind acc = - let rarity = linearInterpolation (IK.irarity kind) + -- Don't consider lvlSpawned for uniques. + let ld = if IK.Unique `elem` IK.iaspects kind then ldAbs else ldSpawned + rarity = linearInterpolation ld (IK.irarity kind) in (q * p * rarity, ((ik, kind), itemGroup)) : acc g (itemGroup, q) = ofoldrGroup itemGroup (f itemGroup q) [] freqDepth = concatMap g itemFreq - freq = toFreq ("newItem ('" <> tshow ld <> ")") freqDepth + freq = toFreq ("newItem ('" <> tshow ldSpawned <> ")") freqDepth if nullFreq freq then return Nothing else do ((itemKindId, itemKind), itemGroup) <- frequency freq + -- Number of new items/actors unaffected by number of spawned actors. itemN <- castDice ldepth totalDepth (IK.icount itemKind) seed <- fmap toEnum random let itemBase = buildItem flavour discoRev itemKindId itemKind jlid itemK = max 1 itemN itemTimer = [] - itemDisco = Just ItemDisco {itemKindId, itemKind, itemAE = Just iae} + itemDiscoData = ItemDisco {itemKindId, itemKind, itemAE = Just iae} + itemDisco = Just itemDiscoData + -- Bonuses on items/actors unaffected by number of spawned actors. iae = seedToAspectsEffects seed itemKind ldepth totalDepth itemFull = ItemFull {..} return $ Just ( (jkindIx itemBase, iae) , itemFull + , itemDiscoData , seed , itemGroup ) diff --git a/Game/LambdaHack/Server/ItemServer.hs b/Game/LambdaHack/Server/ItemServer.hs --- a/Game/LambdaHack/Server/ItemServer.hs +++ b/Game/LambdaHack/Server/ItemServer.hs @@ -7,23 +7,30 @@ import Control.Monad import qualified Data.EnumMap.Strict as EM +import qualified Data.EnumSet as ES +import Data.Function import qualified Data.HashMap.Strict as HM -import Data.Key (mapWithKeyM_) +import Data.List import Data.Maybe +import Data.Ord +import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState 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.Msg import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Content.ItemKind (ItemKind) +import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK import Game.LambdaHack.Server.ItemRev @@ -31,25 +38,34 @@ import Game.LambdaHack.Server.State registerItem :: (MonadAtomic m, MonadServer m) - => Item -> ItemKnown -> ItemSeed -> Int -> Container -> Bool + => ItemFull -> ItemKnown -> ItemSeed -> Int -> Container -> Bool -> m ItemId -registerItem item itemKnown@(_, iae) seed k container verbose = do +registerItem itemFull itemKnown@(_, iae) seed k container verbose = do itemRev <- getsServer sitemRev let cmd = if verbose then UpdCreateItem else UpdSpotItem case HM.lookup itemKnown itemRev of Just iid -> do -- TODO: try to avoid this case for createItems, -- to make items more interesting - execUpdAtomic $ cmd iid item (k, []) container + execUpdAtomic $ cmd iid (itemBase itemFull) (k, []) container return iid Nothing -> do + let fovSight = fromMaybe 0 + $ strengthFromEqpSlot IK.EqpSlotAddSight itemFull + fovSmell = fromMaybe 0 + $ strengthFromEqpSlot IK.EqpSlotAddSmell itemFull + fovLight = fromMaybe 0 + $ strengthFromEqpSlot IK.EqpSlotAddLight itemFull + ssl = FovCache3{..} icounter <- getsServer sicounter modifyServer $ \ser -> - ser { sicounter = succ icounter - , sitemRev = HM.insert itemKnown icounter (sitemRev ser) + ser { sdiscoEffect = EM.insert icounter iae (sdiscoEffect ser) , sitemSeedD = EM.insert icounter seed (sitemSeedD ser) - , sdiscoEffect = EM.insert icounter iae (sdiscoEffect ser)} - execUpdAtomic $ cmd icounter item (k, []) container + , sitemRev = HM.insert itemKnown icounter (sitemRev ser) + , sItemFovCache = if ssl == emptyFovCache3 then sItemFovCache ser + else EM.insert icounter ssl (sItemFovCache ser) + , sicounter = succ icounter } + execUpdAtomic $ cmd icounter (itemBase itemFull) (k, []) container return $! icounter createLevelItem :: (MonadAtomic m, MonadServer m) @@ -65,51 +81,68 @@ Kind.COps{cotile} <- getsState scops let embeds = Tile.embedItems cotile tk causes = Tile.causeEffects cotile tk - -- TODO: unack this, e.g., by turning each Cause into Embed + -- TODO: unhack this, e.g., by turning each Cause into Embed itemFreq = zip embeds (repeat 1) - ++ if not (null causes) && null embeds - then [("hero", 1)] -- hack: the bag, not item, is relevant - else [] + ++ -- Hack: the bag, not item, is relevant. + [("hero", 1) | not (null causes) && null embeds] container = CEmbed lid pos void $ rollAndRegisterItem lid itemFreq container False Nothing rollItem :: (MonadAtomic m, MonadServer m) - => LevelId -> Freqs ItemKind - -> m (Maybe (ItemKnown, ItemFull, ItemSeed, GroupName ItemKind)) -rollItem lid itemFreq = do + => Int -> LevelId -> Freqs ItemKind + -> m (Maybe ( ItemKnown, ItemFull, ItemDisco + , ItemSeed, GroupName ItemKind )) +rollItem lvlSpawned lid itemFreq = do cops <- getsState scops flavour <- getsServer sflavour discoRev <- getsServer sdiscoKindRev + uniqueSet <- getsServer suniqueSet totalDepth <- getsState stotalDepth Level{ldepth} <- getLevel lid - rndToAction $ newItem cops flavour discoRev itemFreq lid ldepth totalDepth + m5 <- rndToAction $ newItem cops flavour discoRev uniqueSet + itemFreq lvlSpawned lid ldepth totalDepth + case m5 of + Just (_, _, ItemDisco{ itemKindId + , itemAE=Just ItemAspectEffect{jaspects}}, _, _) -> + when (IK.Unique `elem` jaspects) $ + modifyServer $ \ser -> + ser {suniqueSet = ES.insert itemKindId (suniqueSet ser)} + _ -> return () + return m5 rollAndRegisterItem :: (MonadAtomic m, MonadServer m) => LevelId -> Freqs ItemKind -> Container -> Bool -> Maybe Int -> m (Maybe (ItemId, (ItemFull, GroupName ItemKind))) rollAndRegisterItem lid itemFreq container verbose mk = do - m4 <- rollItem lid itemFreq - case m4 of + -- Power depth of new items unaffected by number of spawned actors. + m5 <- rollItem 0 lid itemFreq + case m5 of Nothing -> return Nothing - Just (itemKnown, itemFullRaw, seed, itemGroup) -> do - let itemFull = itemFullRaw {itemK = fromMaybe (itemK itemFullRaw) mk} - iid <- registerItem (itemBase itemFull) itemKnown seed + Just (itemKnown, itemFullRaw, itemDisco, seed, itemGroup) -> do + let item = itemBase itemFullRaw + trunkName = makePhrase [MU.WownW (MU.Text $ jname item) "trunk"] + itemTrunk = if null $ IK.ikit $ itemKind itemDisco + then item + else item {jname = trunkName} + itemFull = itemFullRaw { itemK = fromMaybe (itemK itemFullRaw) mk + , itemBase = itemTrunk } + iid <- registerItem itemFull itemKnown seed (itemK itemFull) container verbose return $ Just (iid, (itemFull, itemGroup)) placeItemsInDungeon :: forall m. (MonadAtomic m, MonadServer m) => m () placeItemsInDungeon = do Kind.COps{cotile} <- getsState scops - let initialItems lid (Level{lfloor, ltile, litemNum, lxsize, lysize}) = do + let initialItems (lid, Level{lfloor, ltile, litemNum, lxsize, lysize}) = do let factionDist = max lxsize lysize - 5 placeItems :: [Point] -> Int -> m () placeItems _ 0 = return () placeItems lfloorKeys n = do let dist p = minimum $ maxBound : map (chessDist p) lfloorKeys - pos <- rndToAction $ findPosTry 100 ltile + pos <- rndToAction $ findPosTry 500 ltile (\_ t -> Tile.isWalkable cotile t - && (not $ Tile.hasFeature cotile TK.NoItem t)) + && not (Tile.hasFeature cotile TK.NoItem t)) [ \p t -> Tile.hasFeature cotile TK.OftenItem t && dist p > factionDist `div` 5 , \p t -> Tile.hasFeature cotile TK.OftenItem t @@ -132,14 +165,22 @@ placeItems (pos : lfloorKeys) (n - 1) placeItems (EM.keys lfloor) litemNum dungeon <- getsState sdungeon - mapWithKeyM_ initialItems dungeon + -- Make sure items on easy levels are generated first, to avoid all + -- artifacts on deep levels. + let absLid = abs . fromEnum + fromEasyToHard = sortBy (comparing absLid `on` fst) $ EM.assocs dungeon + mapM_ initialItems fromEasyToHard embedItemsInDungeon :: (MonadAtomic m, MonadServer m) => m () embedItemsInDungeon = do - let embedItems lid (Level{ltile}) = - PointArray.mapWithKeyM_A (embedItem lid) ltile + let embedItems (lid, Level{ltile}) = + PointArray.mapWithKeyMA (embedItem lid) ltile dungeon <- getsState sdungeon - mapWithKeyM_ embedItems dungeon + -- Make sure items on easy levels are generated first, to avoid all + -- artifacts on deep levels. + let absLid = abs . fromEnum + fromEasyToHard = sortBy (comparing absLid `on` fst) $ EM.assocs dungeon + mapM_ embedItems fromEasyToHard fullAssocsServer :: MonadServer m => ActorId -> [CStore] -> m [(ItemId, ItemFull)] @@ -160,7 +201,8 @@ discoKind <- getsServer sdiscoKind discoEffect <- getsServer sdiscoEffect s <- getState - let itemToF iid = itemToFull cops discoKind discoEffect iid (getItemBody iid s) + let itemToF iid = + itemToFull cops discoKind discoEffect iid (getItemBody iid s) return itemToF -- | Mapping over actor's items from a give store. diff --git a/Game/LambdaHack/Server/LoopServer.hs b/Game/LambdaHack/Server/LoopServer.hs --- a/Game/LambdaHack/Server/LoopServer.hs +++ b/Game/LambdaHack/Server/LoopServer.hs @@ -43,14 +43,17 @@ import Game.LambdaHack.Server.StartServer import Game.LambdaHack.Server.State --- | Start a game session. Loop, communicating with clients. +-- | Start a game session, including the clients, and then loop, +-- communicating with the clients. loopSer :: (MonadAtomic m, MonadServerReadRequest m) - => DebugModeSer + => Kind.COps -- ^ game content + -> DebugModeSer -- ^ server debug parameters -> (FactionId -> ChanServer ResponseUI RequestUI -> IO ()) + -- ^ the code to run for UI clients -> (FactionId -> ChanServer ResponseAI RequestAI -> IO ()) - -> Kind.COps + -- ^ the code to run for AI clients -> m () -loopSer sdebug executorUI executorAI !cops = do +loopSer cops sdebug executorUI executorAI = do -- Recover states and launch clients. let updConn = updateConn executorUI executorAI restored <- tryRestore cops sdebug @@ -73,13 +76,13 @@ execUpdAtomic $ UpdResumeServer $ updateCOps setCurrentCops sRaw -- We dump RNG seeds here, in case the game wasn't run -- with --dumpInitRngs previously and we need to seeds. - when (sdumpInitRngs sdebug) $ dumpRngs + when (sdumpInitRngs sdebug) dumpRngs _ -> do -- Starting the first new game for this savefile. -- Set up commandline debug mode let mrandom = case restored of Just (_, ser) -> Just $ srandom ser Nothing -> Nothing - s <- gameReset cops sdebug mrandom + s <- gameReset cops sdebug Nothing mrandom sdebugNxt <- initDebug cops sdebug let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing} modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs @@ -97,7 +100,7 @@ -- Run the leader and other actors moves. Eventually advance the time -- and repeat. let loop = do - let factionArena fact = do + let factionArena fact = case gleader fact of -- Even spawners and horrors need an active arena -- for their leader, or they start clogging stairs. @@ -108,7 +111,7 @@ factionD <- getsState sfactionD marenas <- mapM factionArena $ EM.elems factionD let arenas = ES.toList $ ES.fromList $ catMaybes marenas - assert (not $ null arenas) skip -- game over not caught earlier + let !_A = assert (not $ null arenas) () -- game over not caught earlier mapM_ handleActors arenas quit <- getsServer squit if quit then do @@ -128,8 +131,7 @@ let stdRuleset = Kind.stdRuleset corule writeSaveClips = rwriteSaveClips stdRuleset leadLevelClips = rleadLevelClips stdRuleset - ageProcessed lid processed = - EM.insertWith absoluteTimeAdd lid timeClip processed + ageProcessed lid = EM.insertWith absoluteTimeAdd lid timeClip ageServer lid ser = ser {sprocessed = ageProcessed lid $ sprocessed ser} mapM_ (modifyServer . ageServer) arenas execUpdAtomic $ UpdAgeGame (Delta timeClip) arenas @@ -145,7 +147,7 @@ when (clipN `mod` leadLevelClips == 0) leadLevelSwitch if clipMod == 1 then do -- Periodic activation only once per turn, for speed, but on all arenas. - mapM_ activatePeriodicLevel arenas + mapM_ applyPeriodicLevel arenas -- Add monsters each turn, not each clip. -- Do this on only one of the arenas to prevent micromanagement, -- e.g., spreading leaders across levels to bump monster generation. @@ -165,13 +167,13 @@ else return True -- | Trigger periodic items for all actors on the given level. -activatePeriodicLevel :: (MonadAtomic m, MonadServer m) => LevelId -> m () -activatePeriodicLevel lid = do +applyPeriodicLevel :: (MonadAtomic m, MonadServer m) => LevelId -> m () +applyPeriodicLevel lid = do discoEffect <- getsServer sdiscoEffect - let activatePeriodicItem c aid iid = + let applyPeriodicItem c aid iid = case EM.lookup iid discoEffect of Just ItemAspectEffect{jeffects, jaspects} -> - if IK.Periodic `elem` jaspects then do + when (IK.Periodic `elem` jaspects) $ do -- Check if the item is still in the bag (previous items act!). bag <- getsState $ getCBag c case iid `EM.lookup` bag of @@ -180,18 +182,16 @@ -- In periodic activation, consider *only* recharging effects. effectAndDestroy aid aid iid c True (allRecharging jeffects) jaspects kit - else - return () _ -> assert `failure` (lid, aid, c, iid) - activatePeriodicCStore aid cstore = do + applyPeriodicCStore aid cstore = do let c = CActor aid cstore bag <- getsState $ getCBag c - mapM_ (activatePeriodicItem c aid) $ EM.keys bag - activatePeriodicActor aid = do - activatePeriodicCStore aid COrgan - activatePeriodicCStore aid CEqp + mapM_ (applyPeriodicItem c aid) $ EM.keys bag + applyPeriodicActor aid = do + applyPeriodicCStore aid COrgan + applyPeriodicCStore aid CEqp allActors <- getsState $ actorRegularAssocs (const True) lid - mapM_ (\(aid, _) -> activatePeriodicActor aid) allActors + mapM_ (\(aid, _) -> applyPeriodicActor aid) allActors -- | Perform moves for individual actors, as long as there are actors -- with the next move time less or equal to the end of current cut-off. @@ -206,11 +206,11 @@ factionD <- getsState sfactionD s <- getState let -- Actors of the same faction move together. - -- TODO: insert wrt the order, instead of sorting - isLeader (aid, b) = Just aid /= fmap fst (gleader (factionD EM.! bfid b)) - notDead (_, b) = if bproj b then bhp b >= 0 else bhp b > 0 + notDead (_, b) = not $ actorDying b + notProj (_, b) = not $ bproj b + notLeader (aid, b) = Just aid /= fmap fst (gleader (factionD EM.! bfid b)) order = Ord.comparing $ - notDead &&& bfid . snd &&& isLeader &&& bsymbol . snd + notDead &&& notProj &&& bfid . snd &&& notLeader &&& bsymbol . snd (atime, as) = EM.findMin lprio ams = map (\a -> (a, getActorBody a s)) as mnext | EM.null lprio = Nothing -- no actor alive, wait until it spawns @@ -221,25 +221,21 @@ case mnext of _ | quit -> return () Nothing -> return () - Just (aid, b) | maybe False (null .fst) (btrajectory b) && bproj b -> do - -- A projectile drops to the ground due to obstacles or range. - assert (bproj b) skip + Just (aid, b) | bproj b && maybe True (null . fst) (btrajectory b) -> do startActor aid + -- A projectile drops to the ground due to obstacles or range. + -- The carried item is not destroyed, but drops to the ground. dieSer aid b False handleActors lid - Just (aid, b) | bhp b < 0 && bproj b -> do - -- A projectile hits an actor. The carried item is destroyed. + Just (aid, b) | bhp b <= 0 -> do startActor aid - dieSer aid b True - handleActors lid - Just (aid, b) | bhp b <= 0 && not (bproj b) -> do - -- An actor dies. Items drop to the ground + -- If @b@ is a projectile and it hits an actor, + -- the carried item is destroyed and that's all. + -- Otherwise, an actor dies, items drop to the ground -- and possibly a new leader is elected. - startActor aid - dieSer aid b False + dieSer aid b (bproj b) handleActors lid Just (aid, body) -> do - startActor aid let side = bfid body fact = factionD EM.! side mleader = gleader fact @@ -265,8 +261,10 @@ when (hasWait /= bwait bPre) $ execUpdAtomic $ UpdWaitActor aidNew hasWait if isJust $ btrajectory body then do - timed <- setTrajectory aid - when timed $ advanceTime aid + setTrajectory aid + b2 <- getsState $ getActorBody aid + unless (bproj b2 && actorDying b2) $ + advanceTime aid else if queryUI then do cmdS <- sendQueryUI side aid -- TODO: check that the command is legal first, report and reject, @@ -275,7 +273,7 @@ let hasWait (ReqUITimed ReqWait{}) = True hasWait (ReqUILeader _ _ cmd) = hasWait cmd hasWait _ = False - maybe skip (setBWait (hasWait cmdS)) aidNew + maybe (return ()) (setBWait (hasWait cmdS)) aidNew -- Advance time once, after the leader switched perhaps many times. -- Sometimes this may result in a double move of the new leader, -- followed by a double pause. Or a fractional variant of that. @@ -283,8 +281,12 @@ -- for the old leader, but otherwise his time is undisturbed. -- He is able to move normally in the same turn, immediately -- after the new leader completes his move. - maybe skip advanceTime aidNew + -- Warning: when the action is performed on the server, + -- the time of the actor is different than when client prepared that + -- action, so any client checks involving time should discount this. + maybe (return ()) advanceTime aidNew action + maybe (return ()) managePerTurn aidNew else do -- Clear messages in the UI client (if any), if the actor -- is a leader (which happens when a UI client is fully @@ -301,6 +303,9 @@ -- AI always takes time and so doesn't loop. advanceTime aidNew action + managePerTurn aidNew + b3 <- getsState $ getActorBody aid + unless (waitedLastTurn b3) $ startActor aid handleActors lid gameExit :: (MonadAtomic m, MonadServerReadRequest m) => m () @@ -315,17 +320,19 @@ fovMode <- getsServer $ sfovMode . sdebugSer ser <- getServer pers <- getsState $ \s -> dungeonPerception (fromMaybe Digital fovMode) s ser - assert (persAccumulated == pers `blame` "wrong accumulated perception" - `twith` (persAccumulated, pers)) skip + let !_A = assert (persAccumulated == pers + `blame` "wrong accumulated perception" + `twith` (persAccumulated, pers)) () + return () restartGame :: (MonadAtomic m, MonadServerReadRequest m) - => m () -> m () -> m () -restartGame updConn loop = do + => m () -> m () -> Maybe (GroupName ModeKind) -> m () +restartGame updConn loop mgameMode = do tellGameClipPS cops <- getsState scops sdebugNxt <- getsServer sdebugNxt srandom <- getsServer srandom - s <- gameReset cops sdebugNxt $ Just srandom + s <- gameReset cops sdebugNxt mgameMode (Just srandom) let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing} modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs , sdebugSer = debugBarRngs } @@ -362,38 +369,30 @@ -- 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 Bool +setTrajectory :: (MonadAtomic m, MonadServer m) => ActorId -> m () setTrajectory aid = do cops <- getsState scops b <- getsState $ getActorBody aid lvl <- getLevel $ blid b - let clearTrajectory speed = do + case btrajectory b of + Just (d : lv, speed) -> + if not $ accessibleDir cops lvl (bpos b) d + then do -- Lose HP due to bumping into an obstacle. execUpdAtomic $ UpdRefillHP aid minusM execUpdAtomic $ UpdTrajectory aid (btrajectory b) (Just ([], speed)) - return $ not $ bproj b -- projectiles must vanish soon - case btrajectory b of - Just ((d : lv), speed) -> - if not $ accessibleDir cops lvl (bpos b) d - then clearTrajectory speed else do when (bproj b && null lv) $ do let toColor = Color.BrBlack when (bcolor b /= toColor) $ execUpdAtomic $ UpdColorActor aid (bcolor b) toColor - reqMove aid d -- hit clears trajectory of non-projectiles + reqMove aid d -- hit clears trajectory of non-projectiles in reqMelee b2 <- getsState $ getActorBody aid - if actorDying b2 then return $ not $ bproj b -- don't clear trajectory - else do - unless (maybe False (null . fst) (btrajectory b2)) $ - execUpdAtomic $ UpdTrajectory aid - (btrajectory b2) - (Just (lv, speed)) - return True + unless (btrajectory b2 == Just (lv, speed)) $ -- cleared in reqMelee + execUpdAtomic $ UpdTrajectory aid (btrajectory b2) (Just (lv, speed)) Just ([], _) -> do -- non-projectile actor stops flying - assert (not $ bproj b) skip + let !_A = assert (not $ bproj b) () execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing - return False _ -> assert `failure` "Nothing trajectory" `twith` (aid, b) 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 @@ -27,11 +27,11 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import System.Directory +import System.Exit (exitFailure) import System.FilePath import System.IO import qualified System.Random as R import System.Time -import System.Exit (exitFailure) import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState @@ -102,8 +102,8 @@ hFlush stderr -- TODO: refactor wrt Game.LambdaHack.Common.Save --- | Read the high scores table. Return the empty table if no file. -restoreScore :: MonadServer m => Kind.COps -> m HighScore.ScoreTable +-- | Read the high scores dictionary. Return the empty table if no file. +restoreScore :: MonadServer m => Kind.COps -> m HighScore.ScoreDict restoreScore Kind.COps{corule} = do let stdRuleset = Kind.stdRuleset corule scoresFile = rscoresFile stdRuleset @@ -120,7 +120,7 @@ handler e = do let msg = "High score restore failed. The error message is:" <+> (T.unwords . T.lines) (tshow e) - delayPrint $ msg + delayPrint msg return Nothing either handler return res maybe (return HighScore.empty) return mscore @@ -129,7 +129,7 @@ registerScore :: MonadServer m => Status -> Maybe Actor -> FactionId -> m () registerScore status mbody fid = do cops@Kind.COps{corule} <- getsState scops - assert (maybe True ((fid ==) . bfid) mbody) skip + let !_A = assert (maybe True ((fid ==) . bfid) mbody) () fact <- getsState $ (EM.! fid) . sfactionD total <- case mbody of Just body -> getsState $ snd . calculateTotal body @@ -142,12 +142,12 @@ scoresFile = rscoresFile stdRuleset dataDir <- liftIO appDataDir -- Re-read the table in case it's changed by a concurrent game. - table <- restoreScore cops + scoreDict <- restoreScore cops + gameModeId <- getsState sgameModeId time <- getsState stime date <- liftIO getClockTime DebugModeSer{sdifficultySer} <- getsServer sdebugSer factionD <- getsState sfactionD - loots <- factionLoots fid bench <- getsServer $ sbenchmark . sdebugCli . sdebugSer let path = dataDir scoresFile outputScore (worthMentioning, (ntable, pos)) = @@ -156,9 +156,9 @@ debugPossiblyPrint $ T.intercalate "\n" $ HighScore.showScore (pos, HighScore.getRecord pos ntable) else - if worthMentioning then - liftIO $ encodeEOF path (ntable :: HighScore.ScoreTable) - else return () + let nScoreDict = EM.insert gameModeId ntable scoreDict + in when (worthMentioning) $ + liftIO $ encodeEOF path (nScoreDict :: HighScore.ScoreDict) diff | not $ fhasUI $ gplayer fact = difficultyDefault | otherwise = sdifficultySer theirVic (fi, fa) | isAtWar fact fi @@ -168,10 +168,12 @@ ourVic (fi, fa) | isAllied fact fi || fi == fid = Just $ gvictims fa | otherwise = Nothing ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD + table = HighScore.getTable gameModeId scoreDict registeredScore = HighScore.register table total time status date diff (fname $ gplayer fact) - ourVictims theirVictims loots + ourVictims theirVictims + (fhiCondPoly $ gplayer fact) outputScore registeredScore resetSessionStart :: MonadServer m => m () @@ -263,4 +265,4 @@ -> m R.StdGen getSetGen mrng = case mrng of Just rnd -> return rnd - Nothing -> liftIO $ R.newStdGen + Nothing -> liftIO R.newStdGen diff --git a/Game/LambdaHack/Server/PeriodicServer.hs b/Game/LambdaHack/Server/PeriodicServer.hs --- a/Game/LambdaHack/Server/PeriodicServer.hs +++ b/Game/LambdaHack/Server/PeriodicServer.hs @@ -1,7 +1,8 @@ -- | Server operations performed periodically in the game loop -- and related operations. module Game.LambdaHack.Server.PeriodicServer - ( spawnMonster, addAnyActor, dominateFidSfx, advanceTime, leadLevelSwitch + ( spawnMonster, addAnyActor, dominateFidSfx + , advanceTime, managePerTurn, leadLevelSwitch ) where import Control.Exception.Assert.Sugar @@ -18,6 +19,7 @@ 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 @@ -33,7 +35,6 @@ import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.TileKind as TK import Game.LambdaHack.Server.CommonServer -import Game.LambdaHack.Server.ItemRev import Game.LambdaHack.Server.ItemServer import Game.LambdaHack.Server.MonadServer import Game.LambdaHack.Server.State @@ -43,17 +44,16 @@ -- We assume heroes are never spawned. spawnMonster :: (MonadAtomic m, MonadServer m) => LevelId -> m () spawnMonster lid = do - -- We check the number of current dungeon dwellers (whether spawned or not) - -- to decide if more should be spawned. - f <- getsState $ \s fid -> not $ fcanEscape $ gplayer $ sfactionD s EM.! fid - spawns <- getsState $ actorRegularList f lid totalDepth <- getsState stotalDepth -- TODO: eliminate the defeated and victorious faction from lactorFreq; -- then fcanEscape and fneverEmpty make sense for spawning factions Level{ldepth, lactorCoeff, lactorFreq} <- getLevel lid + lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup lid . snumSpawned rc <- rndToAction - $ monsterGenChance ldepth totalDepth (length spawns) lactorCoeff + $ monsterGenChance ldepth totalDepth lvlSpawned lactorCoeff when rc $ do + modifyServer $ \ser -> + ser {snumSpawned = EM.insert lid (lvlSpawned + 1) $ snumSpawned ser} time <- getsState $ getLocalTime lid maid <- addAnyActor lactorFreq lid time Nothing case maid of @@ -71,17 +71,14 @@ -- We bootstrap the actor by first creating the trunk of the actor's body -- contains the constant properties. cops <- getsState scops - flavour <- getsServer sflavour - discoRev <- getsServer sdiscoKindRev - totalDepth <- getsState stotalDepth - lvl@Level{ldepth} <- getLevel lid + lvl <- getLevel lid factionD <- getsState sfactionD - m4 <- rndToAction - $ newItem cops flavour discoRev actorFreq lid ldepth totalDepth + lvlSpawned <- getsServer $ fromMaybe 0 . EM.lookup lid . snumSpawned + m4 <- rollItem lvlSpawned lid actorFreq case m4 of Nothing -> return Nothing - Just (itemKnown, trunkFull, seed, _) -> do - let ik = maybe (assert `failure` trunkFull) itemKind $ itemDisco trunkFull + Just (itemKnown, trunkFull, itemDisco, seed, _) -> do + let ik = itemKind itemDisco freqNames = map fst $ IK.ifreq ik f fact = fgroup (gplayer fact) factNames = map f $ EM.elems factionD @@ -94,54 +91,70 @@ pers <- getsServer sper let allPers = ES.unions $ map (totalVisible . (EM.! lid)) $ EM.elems $ EM.delete fid pers -- expensive :( + mobile = any (`elem` freqNames) ["civilian", "horror"] pos <- case mpos of Just pos -> return pos Nothing -> do - rollPos <- getsState $ rollSpawnPos cops allPers lid lvl fid + fact <- getsState $ (EM.! fid) . sfactionD + rollPos <- getsState $ rollSpawnPos cops allPers mobile lid lvl fact rndToAction rollPos - let container = (CTrunk fid lid pos) - trunkId <- - registerItem (itemBase trunkFull) itemKnown seed - (itemK trunkFull) container False + let container = CTrunk fid lid pos + trunkId <- registerItem trunkFull itemKnown seed + (itemK trunkFull) container False addActorIid trunkId trunkFull False fid pos lid id "it" time rollSpawnPos :: Kind.COps -> ES.EnumSet Point - -> LevelId -> Level -> FactionId -> State + -> Bool -> LevelId -> Level -> Faction -> State -> Rnd Point rollSpawnPos Kind.COps{cotile} visible - lid Level{ltile, lxsize, lysize} fid s = do - let factionDist = max lxsize lysize - 5 - inhabitants = actorList (/= fid) lid s -- projectiles can have cameras + mobile lid Level{ltile, lxsize, lysize} fact s = do + let inhabitants = actorRegularList (isAtWar fact) lid s as = actorList (const True) lid s isLit = Tile.isLit cotile - distantAtLeast d p _ = - all (\b -> chessDist (bpos b) p > d) inhabitants + distantSo df p _ = + all (\b -> df $ chessDist (bpos b) p) inhabitants + middlePos = Point (lxsize `div` 2) (lysize `div` 2) + distantMiddle d p _ = chessDist p middlePos < d + condList | mobile = + [ \_ t -> not (isLit t) -- no such tiles on some maps + , distantSo (<= 10) -- try to harass enemies + , distantSo (>= 5) -- but leave room for yourself for ranged combat + , distantSo (<= 20) -- but applying pressure is more important + ] + | otherwise = + [ distantMiddle 5 + , distantMiddle 10 + , distantMiddle 20 + , distantMiddle 50 + , distantMiddle 100 + ] -- Not considering TK.OftenActor, because monsters emerge from hidden ducts, -- which are easier to hide in crampy corridors that lit halls. - findPosTry 100 ltile + findPosTry (if mobile then 500 else 100) ltile ( \p t -> Tile.isWalkable cotile t && not (Tile.hasFeature cotile TK.NoActor t) && unoccupied as p) - [ \_ t -> not (isLit t) -- no such tiles on some maps - , distantAtLeast factionDist - , distantAtLeast $ factionDist `div` 2 - , distantAtLeast $ factionDist `div` 4 - , distantAtLeast $ factionDist `div` 6 - , \p _ -> not $ p `ES.member` visible - , distantAtLeast 3 -- otherwise a fast actor can walk and hit in one turn - ] + (condList + ++ [ \p _ -> not (p `ES.member` visible) -- surprise and believability + , distantSo (>= 3) -- otherwise fast actor approach and hit in one turn + ]) dominateFidSfx :: (MonadAtomic m, MonadServer m) => FactionId -> ActorId -> m Bool dominateFidSfx fid target = do - -- Actors that never ever move can't be dominated - actorSk <- maxActorSkillsServer target - let canMove = EM.findWithDefault 0 Ability.AbMove actorSk > 0 - if canMove + 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. + activeItems <- activeItemsServer target + let actorMaxSk = sumSkills activeItems + canMove = EM.findWithDefault 0 Ability.AbMove actorMaxSk > 0 + && EM.findWithDefault 0 Ability.AbTrigger actorMaxSk > 0 + && EM.findWithDefault 0 Ability.AbAlter actorMaxSk > 0 + if canMove && not (bproj tb) then do - tb <- getsState $ getActorBody target let execSfx = execSfxAtomic - $ SfxEffect (boldfid tb) target IK.Dominate + $ SfxEffect (bfidImpressed tb) target IK.Dominate execSfx dominateFid fid target execSfx @@ -154,24 +167,26 @@ dominateFid fid target = do Kind.COps{cotile} <- getsState scops tb0 <- getsState $ getActorBody target - -- Only record the initial domination as a kill. - discoKind <- getsServer sdiscoKind - trunk <- getsState $ getItemBody $ btrunk tb0 - let ikind = discoKind EM.! jkindIx trunk - when (boldfid tb0 == bfid tb0) $ execUpdAtomic $ UpdRecordKill target ikind 1 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 target CSha CInv tb <- getsState $ getActorBody target - deduceKilled tb + deduceKilled target tb + -- TODO: some messages after game over below? Compare with dieSer. ais <- getsState $ getCarriedAssocs tb calmMax <- sumOrganEqpServer IK.EqpSlotAddMaxCalm target execUpdAtomic $ UpdLoseActor target tb ais let bNew = tb { bfid = fid - , boldfid = bfid tb + , bfidImpressed = bfid tb , bcalm = max 0 $ xM calmMax `div` 2 } execUpdAtomic $ UpdSpotActor target bNew ais + let discoverSeed (iid, cstore) = do + seed <- getsServer $ (EM.! iid) . sitemSeedD + let c = CActor target cstore + execUpdAtomic $ UpdDiscoverSeed c iid seed + aic = getCarriedIidCStore tb + mapM_ discoverSeed aic mleaderOld <- getsState $ gleader . (EM.! fid) . sfactionD -- Keep the leader if he is on stairs. We don't want to clog stairs. keepLeader <- case mleaderOld of @@ -184,28 +199,34 @@ -- Focus on the dominated actor, by making him a leader. execUpdAtomic $ UpdLeadFaction fid mleaderOld (Just (target, Nothing)) --- | Advance the move time for the given actor, check if he's dominated --- and update his calm. We don't update calm once per game turn --- (even though it would make fast actors less overpowered), --- beucase the effects of close enemies would sometimes manifest only after --- a couple of player turns (or perhaps never at all, if the player and enemy --- move away before that moment). A side effect is that under peaceful --- circumstances, non-max calm cases a consistent regeneration UI indicator --- to be displayed each turn (not every few turns). +-- | Advance the move time for the given actor advanceTime :: (MonadAtomic m, MonadServer m) => ActorId -> m () advanceTime aid = do b <- getsState $ getActorBody aid activeItems <- activeItemsServer aid - fact <- getsState $ (EM.! bfid b) . sfactionD let t = ticksPerMeter $ bspeed b activeItems execUpdAtomic $ UpdAgeActor aid t + +-- | Check if the given actor is dominated and update his calm. +-- We don't update calm once per game turn (even though +-- it would make fast actors less overpowered), +-- beucase the effects of close enemies would sometimes manifest only after +-- a couple of player turns (or perhaps never at all, if the player and enemy +-- move away before that moment). A side effect is that under peaceful +-- circumstances, non-max calm causes a consistent Calm regeneration +-- UI indicator to be displayed each turn (not every few turns). +managePerTurn :: (MonadAtomic m, MonadServer m) => ActorId -> m () +managePerTurn aid = do + b <- getsState $ getActorBody aid unless (bproj b) $ do + activeItems <- activeItemsServer aid + fact <- getsState $ (EM.! bfid b) . sfactionD dominated <- if bcalm b == 0 - && boldfid b /= bfid b + && bfidImpressed b /= bfid b && fleaderMode (gplayer fact) /= LeaderNull - -- animals never Calm-dominated - then dominateFidSfx (boldfid b) aid + -- animals/robots never Calm-dominated + then dominateFidSfx (bfidImpressed b) aid else return False unless dominated $ do newCalmDelta <- getsState $ regenCalmDelta b activeItems @@ -230,7 +251,7 @@ LeaderAI _ -> True LeaderUI _ -> False flipFaction fact | not $ canSwitch fact = return () - flipFaction fact = do + flipFaction fact = case gleader fact of Nothing -> return () Just (leader, _) -> do @@ -258,7 +279,7 @@ let freqList = [ (k, (lid, a)) | (lid, itemN, (a, _) : rest) <- ours , not leaderStuck || lid /= blid body - , let len = 1 + (min 10 $ length rest) + , let len = 1 + min 10 (length rest) k = 1000000 `div` (3 * itemN + len) ] unless (null freqList) $ do (lid, a) <- rndToAction $ frequency diff --git a/Game/LambdaHack/Server/ProtocolServer.hs b/Game/LambdaHack/Server/ProtocolServer.hs --- a/Game/LambdaHack/Server/ProtocolServer.hs +++ b/Game/LambdaHack/Server/ProtocolServer.hs @@ -18,6 +18,7 @@ -- * Assorted , killAllClients, childrenServer, updateConn #ifdef EXPOSE_INTERNAL + -- * Internal operations , ConnServerFaction #endif ) where @@ -219,5 +220,5 @@ -- even if UI usage changes, but it works OK thanks to UI faction -- clients distinguished by positive FactionId numbers. forkAI fid connAI -- AI clients always needed, e.g., for auto-explore - maybe skip (forkUI fid) connUI + maybe (return ()) (forkUI fid) connUI liftIO $ mapWithKeyM_ forkClient toSpawn diff --git a/Game/LambdaHack/Server/StartServer.hs b/Game/LambdaHack/Server/StartServer.hs --- a/Game/LambdaHack/Server/StartServer.hs +++ b/Game/LambdaHack/Server/StartServer.hs @@ -3,6 +3,7 @@ ( gameReset, reinitGame, initPer, recruitActors, applyDebug, initDebug ) where +import Control.Applicative import Control.Exception.Assert.Sugar import Control.Monad import qualified Control.Monad.State as St @@ -12,6 +13,7 @@ import Data.List import qualified Data.Map.Strict as M import Data.Maybe +import Data.Ord import Data.Text (Text) import qualified Data.Text as T import Data.Tuple (swap) @@ -61,6 +63,7 @@ Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops pers <- getsServer sper knowMap <- getsServer $ sknowMap . sdebugSer + sdebugCli <- getsServer $ sdebugCli . sdebugSer -- 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. @@ -70,11 +73,8 @@ discoS <- getsServer sdiscoKind let sdiscoKind = let f ik = IK.Identified `elem` IK.ifeature (okind ik) in EM.filter f discoS - sdebugCli <- getsServer $ sdebugCli . sdebugSer - modeName <- getsServer $ sgameMode . sdebugSer - let gameMode = fromMaybe "starting" modeName broadcastUpdAtomic - $ \fid -> UpdRestart fid sdiscoKind (pers EM.! fid) defLocal sdebugCli gameMode + $ \fid -> UpdRestart fid sdiscoKind (pers EM.! fid) defLocal sdebugCli populateDungeon mapFromFuns :: (Bounded a, Enum a, Ord b) => [a -> b] -> M.Map b a @@ -100,12 +100,10 @@ cmap = mapFromFuns [colorToTeamName, colorToPlainName, colorToFancyName] nameoc = lowercase $ head $ T.words fname - fisAI = case fleaderMode of - LeaderNull -> True - LeaderAI _ -> True - LeaderUI _ -> False - prefix | fisAI = "Autonomous" - | otherwise = "Controlled" + prefix = case fleaderMode of + LeaderNull -> "Loose" + LeaderAI _ -> "Autonomous" + LeaderUI _ -> "Controlled" (gcolor, gname) = case M.lookup nameoc cmap of Nothing -> (Color.BrWhite, prefix <+> fname) Just c -> (c, prefix <+> fname <+> "Team") @@ -142,9 +140,10 @@ return $! warFs gameReset :: MonadServer m - => Kind.COps -> DebugModeSer -> Maybe R.StdGen -> m State -gameReset cops@Kind.COps{comode=Kind.Ops{opick, okind, ouniqGroup}} - sdebug mrandom = do + => Kind.COps -> DebugModeSer -> Maybe (GroupName ModeKind) + -> Maybe R.StdGen -> m State +gameReset cops@Kind.COps{comode=Kind.Ops{opick, okind}} + sdebug mGameMode mrandom = do dungeonSeed <- getSetGen $ sdungeonRng sdebug `mplus` mrandom srandom <- getSetGen $ smainRng sdebug `mplus` mrandom scoreTable <- if sfrontendNull $ sdebugCli sdebug then @@ -154,13 +153,13 @@ sstart <- getsServer sstart -- copy over from previous game sallTime <- getsServer sallTime -- copy over from previous game sheroNames <- getsServer sheroNames -- copy over from previous game - let gameMode = fromMaybe "starting" $ sgameMode sdebug + let gameMode = fromMaybe "starting" $ mGameMode `mplus` sgameMode sdebug rnd :: Rnd (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev, - DungeonGen.FreshDungeon) + DungeonGen.FreshDungeon, Kind.Id ModeKind) rnd = do - modeKind <- fmap (fromMaybe $ ouniqGroup "campaign") -- the fallback - $ opick gameMode (const True) - let mode = okind modeKind + modeKindId <- fromMaybe (assert `failure` gameMode) + <$> opick gameMode (const True) + let mode = okind modeKindId automatePS ps = ps {rosterList = map (automatePlayer True) $ rosterList ps} players = if sautomateAll sdebug @@ -170,18 +169,18 @@ (sdiscoKind, sdiscoKindRev) <- serverDiscos cops freshDng <- DungeonGen.dungeonGen cops $ mcaves mode faction <- createFactions (DungeonGen.freshTotalDepth freshDng) players - return (faction, sflavour, sdiscoKind, sdiscoKindRev, freshDng) - let (faction, sflavour, sdiscoKind, sdiscoKindRev, DungeonGen.FreshDungeon{..}) = + return (faction, sflavour, sdiscoKind, sdiscoKindRev, freshDng, modeKindId) + let (faction, sflavour, sdiscoKind, sdiscoKindRev, DungeonGen.FreshDungeon{..}, modeKindId) = St.evalState rnd dungeonSeed defState = defStateGlobal freshDungeon freshTotalDepth - faction cops scoreTable + faction cops scoreTable modeKindId defSer = emptyStateServer { sstart, sallTime, sheroNames, srandom , srngs = RNGs (Just dungeonSeed) (Just srandom) } putServer defSer when (sbenchmark $ sdebugCli sdebug) resetGameStart modifyServer $ \ser -> ser {sdiscoKind, sdiscoKindRev, sflavour} - when (sdumpInitRngs sdebug) $ dumpRngs + when (sdumpInitRngs sdebug) dumpRngs return $! defState -- Spawn initial actors. Clients should notice this, to set their leaders. @@ -197,7 +196,11 @@ case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of (Just ((s, _), _), Just ((e, _), _)) -> (s, e) _ -> assert `failure` "empty dungeon" `twith` dungeon - needInitialCrew = filter ((> 0 ) . finitialActors . gplayer . snd) + -- Players that escape go first to be started over stairs, if possible. + valuePlayer pl = (not $ fcanEscape pl, fname pl) + -- Sorting, to keep games from similar game modes mutually reproducible. + needInitialCrew = sortBy (comparing $ valuePlayer . gplayer . snd) + $ filter ((> 0 ) . finitialActors . gplayer . snd) $ EM.assocs factionD getEntryLevel (_, fact) = max minD $ min maxD $ toEnum $ fentryLevel $ gplayer fact @@ -205,21 +208,23 @@ initialActors lid = do lvl <- getLevel lid let arenaFactions = filter ((== lid) . getEntryLevel) needInitialCrew - representsAlliance (fid2, fact2) = - not $ any (\(fid3, _) -> fid3 < fid2 - && isAllied fact2 fid3) arenaFactions + indexff (fid, _) = findIndex ((== fid) . fst) arenaFactions + representsAlliance ff2@(_, fact2) = + not $ any (\ff3@(fid3, _) -> + indexff ff3 < indexff ff2 + && isAllied fact2 fid3) arenaFactions arenaAlliances = filter representsAlliance arenaFactions - placeAlliance ((fid3, _), ppos) = + placeAlliance ((fid3, _), ppos, timeOffset) = mapM_ (\(fid4, fact4) -> - if isAllied fact4 fid3 || fid4 == fid3 - then placeActors lid ((fid4, fact4), ppos) - else return ()) arenaFactions + when (isAllied fact4 fid3 || fid4 == fid3) $ + placeActors lid ((fid4, fact4), ppos, timeOffset)) + arenaFactions entryPoss <- rndToAction - $ findEntryPoss cops lvl (length arenaAlliances) - mapM_ placeAlliance $ zip arenaAlliances entryPoss - placeActors lid ((fid3, fact3), ppos) = do + $ findEntryPoss cops lid lvl (length arenaAlliances) + mapM_ placeAlliance $ zip3 arenaAlliances entryPoss [0..] + placeActors lid ((fid3, fact3), ppos, timeOffset) = do time <- getsState $ getLocalTime lid - let nmult = 1 + fromEnum fid3 `mod` 4 -- always positive + let nmult = 1 + timeOffset `mod` 4 ntime = timeShift time (timeDeltaScale (Delta timeClip) nmult) validTile t = not $ Tile.hasFeature cotile TK.NoActor t psFree <- getsState $ nearbyFreePoints validTile ppos lid @@ -229,7 +234,7 @@ if not $ fhasNumbers $ gplayer fact3 then recruitActors [p] lid ntime fid3 else do - let hNames = fromMaybe [] $ EM.lookup fid3 sheroNames + let hNames = EM.findWithDefault [] fid3 sheroNames maid <- addHero fid3 p lid hNames (Just n) ntime case maid of Nothing -> return False @@ -283,7 +288,7 @@ addHero bfid ppos lid heroNames mNumber time = do Faction{gcolor, gplayer} <- getsState $ (EM.! bfid) . sfactionD let groupName = fgroup gplayer - mhs <- mapM (\n -> getsState $ \s -> tryFindHeroK s bfid n) [0..9] + mhs <- mapM (\n -> getsState $ tryFindHeroK bfid n) [0..9] let freeHeroK = elemIndex Nothing mhs n = fromMaybe (fromMaybe 100 freeHeroK) mNumber bsymbol = if n < 1 || n > 9 then '@' else Char.intToDigit n @@ -299,16 +304,18 @@ addActor groupName bfid ppos lid tweakBody pronoun time -- | Find starting postions for all factions. Try to make them distant --- from each other. If only one faction, also move it away from any stairs. -findEntryPoss :: Kind.COps -> Level -> Int -> Rnd [Point] -findEntryPoss Kind.COps{cotile} Level{ltile, lxsize, lysize, lstair} k = do +-- from each other. Place as many of the initial factions, as possible, +-- over stairs and escapes. +findEntryPoss :: Kind.COps -> LevelId -> Level -> Int -> Rnd [Point] +findEntryPoss Kind.COps{cotile} + lid Level{ltile, lxsize, lysize, lstair, lescape} k = do let factionDist = max lxsize lysize - 5 dist poss cmin l _ = all (\pos -> chessDist l pos > cmin) poss tryFind _ 0 = return [] tryFind ps n = do np <- findPosTry 1000 ltile -- try really hard, for skirmish fairness (\_ t -> Tile.isWalkable cotile t - && (not $ Tile.hasFeature cotile TK.NoActor t)) + && not (Tile.hasFeature cotile TK.NoActor t)) [ dist ps $ factionDist `div` 2 , dist ps $ factionDist `div` 3 , const (Tile.hasFeature cotile TK.OftenActor) @@ -320,15 +327,23 @@ ] nps <- tryFind (np : ps) (n - 1) return $! np : nps - stairPoss = fst lstair ++ snd lstair + -- Prefer deeper stairs to avoid spawners ambushing explorers. + (deeperStairs, shallowerStairs) = + (if fromEnum lid > 0 then id else swap) lstair + stairPoss = (deeperStairs \\ shallowerStairs) + ++ lescape + ++ shallowerStairs middlePos = Point (lxsize `div` 2) (lysize `div` 2) - assert (k > 0 && factionDist > 0) skip - case k of - 1 -> tryFind stairPoss k + let !_A = assert (k > 0 && factionDist > 0) () + onStairs = take k stairPoss + nk = k - length onStairs + found <- case nk of + 0 -> return [] + 1 -> tryFind onStairs nk 2 -> -- Make sure the first faction's pos is not chosen in the middle. - tryFind [middlePos] k - _ | k > 2 -> tryFind [] k - _ -> assert `failure` k + tryFind (if null onStairs then [middlePos] else onStairs) nk + _ -> tryFind onStairs nk + return $! onStairs ++ found initDebug :: MonadStateRead m => Kind.COps -> DebugModeSer -> m DebugModeSer initDebug Kind.COps{corule} sdebugSer = do diff --git a/Game/LambdaHack/Server/State.hs b/Game/LambdaHack/Server/State.hs --- a/Game/LambdaHack/Server/State.hs +++ b/Game/LambdaHack/Server/State.hs @@ -2,13 +2,13 @@ module Game.LambdaHack.Server.State ( StateServer(..), emptyStateServer , DebugModeSer(..), defDebugModeSer - , RNGs(..) + , RNGs(..), FovCache3(..), emptyFovCache3 ) where import Data.Binary import qualified Data.EnumMap.Strict as EM +import qualified Data.EnumSet as ES import qualified Data.HashMap.Strict as HM -import Data.List import Data.Text (Text) import qualified System.Random as R import System.Time @@ -30,12 +30,17 @@ data StateServer = StateServer { sdiscoKind :: !DiscoveryKind -- ^ full item kind discoveries data , sdiscoKindRev :: !DiscoveryKindRev -- ^ reverse map, used for item creation + , suniqueSet :: !UniqueSet -- ^ already generated unique items , sdiscoEffect :: !DiscoveryEffect -- ^ full item effect&Co data , sitemSeedD :: !ItemSeedDict -- ^ map from item ids to item seeds , sitemRev :: !ItemRev -- ^ reverse id map, used for item creation + , sItemFovCache :: !(EM.EnumMap ItemId FovCache3) + -- ^ (sight, smell, light) aspect bonus + -- of the item; zeroes if not in the map , sflavour :: !FlavourMap -- ^ association of flavour to items , sacounter :: !ActorId -- ^ stores next actor index , sicounter :: !ItemId -- ^ stores next item index + , snumSpawned :: !(EM.EnumMap LevelId Int) , sprocessed :: !(EM.EnumMap LevelId Time) -- ^ actors are processed up to this time , sundo :: ![CmdAtomic] -- ^ atomic commands performed to date @@ -54,6 +59,16 @@ } deriving (Show) +data FovCache3 = FovCache3 + { fovSight :: !Int + , fovSmell :: !Int + , fovLight :: !Int + } + deriving (Show, Eq) + +emptyFovCache3 :: FovCache3 +emptyFovCache3 = FovCache3 0 0 0 + -- | Debug commands. See 'Server.debugArgs' for the descriptions. data DebugModeSer = DebugModeSer { sknowMap :: !Bool @@ -63,6 +78,7 @@ , sallClear :: !Bool , sgameMode :: !(Maybe (GroupName ModeKind)) , sautomateAll :: !Bool + , skeepAutomated :: !Bool , sstopAfter :: !(Maybe Int) , sdungeonRng :: !(Maybe R.StdGen) , smainRng :: !(Maybe R.StdGen) @@ -72,7 +88,7 @@ , sdumpInitRngs :: !Bool , ssavePrefixSer :: !(Maybe String) , sdbgMsgSer :: !Bool - , sdebugCli :: !DebugModeCli + , sdebugCli :: !DebugModeCli -- ^ client debug parameters } deriving Show @@ -87,7 +103,7 @@ dungeonRandomGenerator , maybe "" (\gen -> "--setMainRng \"" ++ show gen ++ "\"") startingRandomGenerator ] - in intercalate " " args + in unwords args -- | Initial, empty game server state. emptyStateServer :: StateServer @@ -95,12 +111,15 @@ StateServer { sdiscoKind = EM.empty , sdiscoKindRev = EM.empty + , suniqueSet = ES.empty , sdiscoEffect = EM.empty , sitemSeedD = EM.empty , sitemRev = HM.empty + , sItemFovCache = EM.empty , sflavour = emptyFlavourMap , sacounter = toEnum 0 , sicounter = toEnum 0 + , snumSpawned = EM.empty , sprocessed = EM.empty , sundo = [] , sper = EM.empty @@ -125,6 +144,7 @@ , sallClear = False , sgameMode = Nothing , sautomateAll = False + , skeepAutomated = False , sstopAfter = Nothing , sdungeonRng = Nothing , smainRng = Nothing @@ -141,12 +161,15 @@ put StateServer{..} = do put sdiscoKind put sdiscoKindRev + put suniqueSet put sdiscoEffect put sitemSeedD put sitemRev + put sItemFovCache -- out of laziness, but it's small put sflavour put sacounter put sicounter + put snumSpawned put sprocessed put sundo put (show srandom) @@ -156,12 +179,15 @@ get = do sdiscoKind <- get sdiscoKindRev <- get + suniqueSet <- get sdiscoEffect <- get sitemSeedD <- get sitemRev <- get + sItemFovCache <- get sflavour <- get sacounter <- get sicounter <- get + snumSpawned <- get sprocessed <- get sundo <- get g <- get @@ -178,6 +204,17 @@ sdebugNxt = defDebugModeSer -- TODO: here difficulty level, etc. from the last session is wiped out return $! StateServer{..} +instance Binary FovCache3 where + put FovCache3{..} = do + put fovSight + put fovSmell + put fovLight + get = do + fovSight <- get + fovSmell <- get + fovLight <- get + return $! FovCache3{..} + instance Binary DebugModeSer where put DebugModeSer{..} = do put sknowMap @@ -187,6 +224,7 @@ put sallClear put sgameMode put sautomateAll + put skeepAutomated put sdifficultySer put sfovMode put ssavePrefixSer @@ -200,6 +238,7 @@ sallClear <- get sgameMode <- get sautomateAll <- get + skeepAutomated <- get sdifficultySer <- get sfovMode <- get ssavePrefixSer <- get 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 @@ -27,7 +27,7 @@ , ("CTRL-k", ([CmdMenu], GameRestart "skirmish")) , ("CTRL-m", ([CmdMenu], GameRestart "ambush")) , ("CTRL-b", ([CmdMenu], GameRestart "battle")) - , ("CTRL-a", ([CmdMenu], GameRestart "campaign")) + , ("CTRL-n", ([CmdMenu], GameRestart "campaign")) , ("CTRL-d", ([CmdMenu], GameDifficultyCycle)) -- Movement and terrain alteration @@ -53,27 +53,32 @@ [ TriggerFeature { verb = "descend" , object = "10 levels" , feature = TK.Cause (IK.Ascend (-10)) } ])) - , ("semicolon", ([CmdMove], StepToTarget)) - , ("colon", ([CmdMove], Macro "go to target for 100 steps" - ["semicolon", "V"])) - , ("CTRL-colon", ([CmdMove], Macro "go to target for 10 steps" - ["semicolon", "CTRL-V"])) - , ("x", ([CmdMove], Macro "explore the closest unknown spot" - [ "BackSpace" - , "CTRL-question", "semicolon", "V" ])) - , ("X", ([CmdMove], Macro "autoexplore 100 times" - [ "BackSpace" - , "'", "CTRL-question", "semicolon", "'" - , "V" ])) - , ("CTRL-X", ([CmdMove], Macro "autoexplore 10 times" - [ "BackSpace" - , "'", "CTRL-question", "semicolon", "'" - , "CTRL-V" ])) + , ("semicolon", + ( [CmdMove] + , Macro "go to crosshair for 100 steps" + ["CTRL-semicolon", "CTRL-period", "V"] )) + , ("colon", + ( [CmdMove] + , Macro "run selected to crosshair for 100 steps" + ["CTRL-colon", "CTRL-period", "V"] )) + , ("x", + ( [CmdMove] + , Macro "explore the closest unknown spot" + [ "CTRL-question" -- no semicolon + , "CTRL-period", "V" ] )) + , ("X", + ( [CmdMove] + , Macro "autoexplore 100 times" + ["'", "CTRL-question", "CTRL-period", "'", "V"] )) + , ("CTRL-X", + ( [CmdMove] + , Macro "autoexplore 25 times" + ["'", "CTRL-question", "CTRL-period", "'", "CTRL-V"] )) , ("R", ([CmdMove], Macro "rest (wait 100 times)" ["KP_Begin", "V"])) - , ("CTRL-R", ([CmdMove], Macro "rest (wait 10 times)" + , ("CTRL-R", ([CmdMove], Macro "rest (wait 25 times)" ["KP_Begin", "CTRL-V"])) - , ("c", ([CmdMove], AlterDir + , ("c", ([CmdMove, CmdMinimal], AlterDir [ AlterFeature { verb = "close" , object = "door" , feature = TK.CloseTo "vertical closed door Lit" } @@ -87,32 +92,29 @@ , object = "door" , feature = TK.CloseTo "horizontal closed door Dark" } ])) - , ("CTRL-KP_Begin", ([CmdMove], Macro "" ["KP_Begin"])) - , ("period", ([CmdMove], Macro "" ["KP_Begin"])) - , ("KP_5", ([CmdMove], Macro "" ["KP_Begin"])) - , ("CTRL-KP_5", ([CmdMove], Macro "" ["KP_Begin"])) - , ("i", ([CmdMove], Macro "" ["KP_Begin"])) -- Item use - , ("E", ([CmdItem], DescribeItem CEqp)) - , ("P", ([CmdItem], DescribeItem CInv)) - , ("S", ([CmdItem], DescribeItem CSha)) - , ("G", ([CmdItem], DescribeItem CGround)) - , ("A", ([CmdItem], AllOwned)) + , ("E", ([CmdItem, CmdMinimal], DescribeItem $ MStore CEqp)) + , ("P", ([CmdItem], DescribeItem $ MStore CInv)) + , ("S", ([CmdItem], DescribeItem $ MStore CSha)) + , ("A", ([CmdItem], DescribeItem MOwned)) + , ("G", ([CmdItem], DescribeItem $ MStore CGround)) + , ("@", ([CmdItem], DescribeItem $ MStore COrgan)) + , ("exclam", ([CmdItem], DescribeItem MStats)) , ("g", ([CmdItem, CmdMinimal], - MoveItem [CGround] CEqp (Just "get") "an item" True)) + MoveItem [CGround] CEqp (Just "get") "items" True)) , ("d", ([CmdItem], MoveItem [CEqp, CInv, CSha] CGround - Nothing "an item" False)) - , ("e", ([CmdItem], MoveItem [CInv, CSha] CEqp - Nothing "an item" False)) - , ("p", ([CmdItem], MoveItem [CEqp, CSha] CInv - Nothing "an item into inventory backpack" + Nothing "items" False)) + , ("e", ([CmdItem], MoveItem [CGround, CInv, CSha] CEqp + Nothing "items" False)) + , ("p", ([CmdItem], MoveItem [CGround, CEqp, CSha] CInv + Nothing "items into inventory" False)) - , ("s", ([CmdItem], MoveItem [CInv, CEqp] CSha - Nothing "and share an item" False)) + , ("s", ([CmdItem], MoveItem [CGround, CInv, CEqp] CSha + Nothing "and share items" False)) , ("a", ([CmdItem, CmdMinimal], Apply - [ ApplyItem { verb = "activate" - , object = "applicable item" + [ ApplyItem { verb = "apply" + , object = "consumable" , symbol = ' ' } , ApplyItem { verb = "quaff" , object = "potion" @@ -129,26 +131,27 @@ , symbol = '?' }])) , ("f", ([CmdItem, CmdMinimal], Project [ApplyItem { verb = "fling" - , object = "projectable item" + , object = "projectile" , symbol = ' ' }])) , ("t", ([CmdItem], Project [ApplyItem { verb = "throw" , object = "missile" , symbol = '|' }])) - , ("z", ([CmdItem], Project [ApplyItem { verb = "zap" - , object = "wand" - , symbol = '/' }])) +-- , ("z", ([CmdItem], Project [ApplyItem { verb = "zap" +-- , object = "wand" +-- , symbol = '/' }])) -- Targeting - , ("KP_Multiply", ([CmdTgt, CmdMinimal], TgtEnemy)) + , ("KP_Multiply", ([CmdTgt], TgtEnemy)) , ("backslash", ([CmdTgt], Macro "" ["KP_Multiply"])) - , ("slash", ([CmdTgt], TgtFloor)) - , ("plus", ([CmdTgt], EpsIncr True)) + , ("KP_Divide", ([CmdTgt], TgtFloor)) + , ("bar", ([CmdTgt], Macro "" ["KP_Divide"])) + , ("plus", ([CmdTgt, CmdMinimal], EpsIncr True)) , ("minus", ([CmdTgt], EpsIncr False)) + , ("CTRL-question", ([CmdTgt], CursorUnknown)) + , ("CTRL-I", ([CmdTgt], CursorItem)) + , ("CTRL-braceleft", ([CmdTgt], CursorStair True)) + , ("CTRL-braceright", ([CmdTgt], CursorStair False)) , ("BackSpace", ([CmdTgt], TgtClear)) - , ("CTRL-question", ([CmdTgt], TgtUnknown)) - , ("CTRL-I", ([CmdTgt], TgtItem)) - , ("CTRL-braceleft", ([CmdTgt], TgtStair True)) - , ("CTRL-braceright", ([CmdTgt], TgtStair False)) -- Automation , ("equal", ([CmdAuto], SelectActor)) @@ -156,27 +159,50 @@ , ("v", ([CmdAuto], Repeat 1)) , ("V", ([CmdAuto], Repeat 100)) , ("CTRL-v", ([CmdAuto], Repeat 1000)) - , ("CTRL-V", ([CmdAuto], Repeat 10)) + , ("CTRL-V", ([CmdAuto], Repeat 25)) , ("apostrophe", ([CmdAuto], Record)) , ("CTRL-T", ([CmdAuto], Tactic)) , ("CTRL-A", ([CmdAuto], Automate)) -- Assorted , ("question", ([CmdMeta], Help)) - , ("D", ([CmdMeta], History)) - , ("T", ([CmdMeta], MarkSuspect)) + , ("D", ([CmdMeta, CmdMinimal], History)) + , ("T", ([CmdMeta, CmdMinimal], MarkSuspect)) , ("Z", ([CmdMeta], MarkVision)) , ("C", ([CmdMeta], MarkSmell)) , ("Tab", ([CmdMeta], MemberCycle)) - , ("ISO_Left_Tab", ([CmdMeta], MemberBack)) + , ("ISO_Left_Tab", ([CmdMeta, CmdMinimal], MemberBack)) , ("space", ([CmdMeta], Clear)) , ("Escape", ([CmdMeta, CmdMinimal], Cancel)) - , ("Return", ([CmdMeta], Accept)) + , ("Return", ([CmdMeta, CmdTgt], Accept)) + -- Mouse + , ("LeftButtonPress", + ([CmdMouse], macroLeftButtonPress)) + , ("SHIFT-LeftButtonPress", + ([CmdMouse], macroShiftLeftButtonPress)) + , ("MiddleButtonPress", ([CmdMouse], CursorPointerEnemy)) + , ("SHIFT-MiddleButtonPress", ([CmdMouse], CursorPointerFloor)) + , ("CTRL-MiddleButtonPress", + ([CmdInternal], Macro "" ["SHIFT-MiddleButtonPress"])) + , ("RightButtonPress", ([CmdMouse], TgtPointerEnemy)) + -- Debug and others not to display in help screens , ("CTRL-s", ([CmdDebug], GameSave)) + , ("CTRL-i", ([CmdDebug], GameRestart "battle survival")) , ("CTRL-f", ([CmdDebug], GameRestart "safari")) + , ("CTRL-r", ([CmdDebug], GameRestart "safari survival")) , ("CTRL-e", ([CmdDebug], GameRestart "defense")) - , ("CTRL-O", ([CmdDebug], DescribeItem COrgan)) - ] + , ("CTRL-g", ([CmdDebug], GameRestart "boardgame")) + , ("CTRL-semicolon", ([CmdInternal], MoveOnceToCursor)) + , ("CTRL-colon", ([CmdInternal], RunOnceToCursor)) + , ("CTRL-period", ([CmdInternal], ContinueToCursor)) + , ("CTRL-comma", ([CmdInternal], RunOnceAhead)) + , ("CTRL-LeftButtonPress", + ([CmdInternal], Macro "" ["SHIFT-LeftButtonPress"])) + , ("CTRL-MiddleButtonPress", + ([CmdInternal], Macro "" ["SHIFT-MiddleButtonPress"])) + , ("ALT-space", ([CmdInternal], StopIfTgtMode)) + , ("ALT-minus", ([CmdInternal], SelectWithPointer)) + ] } diff --git a/GameDefinition/Content/CaveKind.hs b/GameDefinition/Content/CaveKind.hs --- a/GameDefinition/Content/CaveKind.hs +++ b/GameDefinition/Content/CaveKind.hs @@ -16,9 +16,9 @@ , validateSingle = validateSingleCaveKind , validateAll = validateAllCaveKind , content = - [rogue, arena, empty, noise, battle, skirmish, ambush, safari1, safari2, safari3] + [rogue, arena, empty, noise, shallow1rogue, battle, skirmish, ambush, safari1, safari2, safari3, boardgame] } -rogue, arena, empty, noise, battle, skirmish, ambush, safari1, safari2, safari3 :: CaveKind +rogue, arena, empty, noise, shallow1rogue, battle, skirmish, ambush, safari1, safari2, safari3, boardgame :: CaveKind rogue = CaveKind { csymbol = 'R' @@ -37,9 +37,9 @@ , cdoorChance = 1%2 , copenChance = 1%10 , chidden = 8 - , cactorCoeff = 20 - , cactorFreq = [("monster", 50), ("animal", 50)] - , citemNum = 15 * d 2 + , cactorCoeff = 150 -- the maze requires time to explore + , cactorFreq = [("monster", 40), ("animal", 60)] + , citemNum = 10 * d 2 , citemFreq = [("useful", 50), ("treasure", 50)] , cplaceFreq = [("rogue", 100)] , cpassable = False @@ -53,17 +53,18 @@ } arena = rogue { csymbol = 'A' - , cname = "Underground city" - , cfreq = [("campaign random", 30), ("caveArena", 1)] + , cname = "Underground library" + , cfreq = [("campaign random", 50), ("caveArena", 1)] , cgrid = DiceXY (2 * d 2) (2 * d 2) , cminPlaceSize = DiceXY (2 * d 2 + 3) 4 - , cdarkChance = d 80 + dl 60 - , cnightChance = 0 + , cdarkChance = d 60 + dl 60 + , cnightChance = d 60 + dl 60 -- trails provide enough light for fun stealth , cmaxVoid = 1%4 , chidden = 1000 - , cactorCoeff = 40 + , cactorCoeff = 100 , cactorFreq = [("monster", 70), ("animal", 30)] - , citemNum = 11 * d 2 -- few rooms + , citemNum = 9 * d 2 -- few rooms + , citemFreq = [("useful", 20), ("treasure", 30), ("any scroll", 50)] , cpassable = True , cdefTile = "arenaSet" , cdarkCorTile = "trailLit" -- let trails give off light @@ -72,7 +73,7 @@ empty = rogue { csymbol = 'E' , cname = "Tall cavern" - , cfreq = [("campaign random", 20), ("caveEmpty", 1)] + , cfreq = [("caveEmpty", 1)] , cgrid = DiceXY (d 2 + 1) 1 , cminPlaceSize = DiceXY 10 10 , cmaxPlaceSize = DiceXY 24 12 @@ -82,9 +83,15 @@ , cmaxVoid = 1%2 , cminStairDist = 50 , chidden = 1000 - , cactorCoeff = 50 - , cactorFreq = [("monster", 10), ("animal", 90)] - , citemNum = 9 * d 2 -- few rooms + , cactorCoeff = 20 + , cactorFreq = [("monster", 2), ("animal", 8), ("immobile vents", 90)] + -- The geysers on lvl 3 act like HP resets. They are needed to avoid + -- cascading failure, if the particular starting conditions were + -- very hard. The items are not reset, even if the are bad, which provides + -- enough of a continuity. Gyesers on lvl 3 are not OP and can't be + -- abused, because they spawn less and less often, they don't heal over + -- max HP and they expire naturally. + , citemNum = 7 * d 2 -- few rooms , cpassable = True , cdefTile = "emptySet" , cdarkCorTile = "floorArenaDark" @@ -92,8 +99,8 @@ } noise = rogue { csymbol = 'N' - , cname = "Glittering cave" - , cfreq = [("campaign random", 10), ("caveNoise", 1)] + , cname = "Leaky, burrowed sediment" + , cfreq = [("campaign random", 20), ("caveNoise", 1)] , cgrid = DiceXY (2 + d 2) 3 , cminPlaceSize = DiceXY 12 5 , cmaxPlaceSize = DiceXY 24 12 @@ -101,15 +108,24 @@ , cauxConnects = 0 , cmaxVoid = 0 , chidden = 1000 - , cactorCoeff = 30 + , cactorCoeff = 200 -- the maze requires time to explore , cactorFreq = [("monster", 80), ("animal", 20)] - , citemNum = 16 * d 2 -- an incentive to explore the labyrinth + , citemNum = 12 * d 2 -- an incentive to explore the labyrinth , cpassable = True , cplaceFreq = [("noise", 100)] , cdefTile = "noiseSet" , cdarkCorTile = "floorArenaDark" , clitCorTile = "floorArenaLit" } +shallow1rogue = rogue + { csymbol = 'D' + , cname = "Entrance to the dungeon" + , cfreq = [("shallow random 1", 100)] + , cdarkChance = 0 + , cactorFreq = filter ((/= "monster") . fst) $ cactorFreq rogue + , citemNum = 15 * d 2 -- lure them in with loot + , citemFreq = filter ((/= "treasure") . fst) $ citemFreq rogue + } battle = rogue -- few lights and many solids, to help the less numerous heroes { csymbol = 'B' , cname = "Old battle ground" @@ -168,7 +184,7 @@ , chidden = 1000 , cactorFreq = [] , citemNum = 22 * d 2 - , citemFreq = [("useful", 100), ("light source", 200)] + , citemFreq = [("useful", 100)] , cplaceFreq = [("ambush", 100)] , cpassable = True , cdefTile = "ambushSet" @@ -178,3 +194,34 @@ safari1 = ambush {cfreq = [("caveSafari1", 1)]} safari2 = battle {cfreq = [("caveSafari2", 1)]} safari3 = skirmish {cfreq = [("caveSafari3", 1)]} +boardgame = CaveKind + { csymbol = 'B' + , cname = "A boardgame" + , cfreq = [("caveBoardgame", 1)] + , cxsize = fst normalLevelBound + 1 + , cysize = snd normalLevelBound + 1 + , cgrid = DiceXY 1 1 + , cminPlaceSize = DiceXY 10 10 + , cmaxPlaceSize = DiceXY 10 10 + , cdarkChance = 0 + , cnightChance = 0 + , cauxConnects = 0 + , cmaxVoid = 0 + , cminStairDist = 0 + , cdoorChance = 0 + , copenChance = 0 + , chidden = 0 + , cactorCoeff = 0 + , cactorFreq = [] + , citemNum = 0 + , citemFreq = [] + , cplaceFreq = [("boardgame", 1)] + , cpassable = False + , cdefTile = "fillerWall" + , cdarkCorTile = "floorCorridorDark" + , clitCorTile = "floorCorridorLit" + , cfillerTile = "fillerWall" + , couterFenceTile = "basic outer fence" + , clegendDarkTile = "legendDark" + , clegendLitTile = "legendLit" + } diff --git a/GameDefinition/Content/ItemKind.hs b/GameDefinition/Content/ItemKind.hs --- a/GameDefinition/Content/ItemKind.hs +++ b/GameDefinition/Content/ItemKind.hs @@ -1,12 +1,14 @@ -- | Item and treasure definitions. module Content.ItemKind ( cdefs ) where +import qualified Data.EnumMap.Strict as EM import Data.List import Content.ItemKindActor import Content.ItemKindBlast import Content.ItemKindOrgan import Content.ItemKindTemporary +import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.ContentDef import Game.LambdaHack.Common.Dice @@ -26,9 +28,9 @@ items :: [ItemKind] items = - [dart, dart200, bolas, harpoon, net, jumpingPole, whetstone, woodenTorch, oilLamp, brassLantern, gorget, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, monocle, ring1, ring2, ring3, ring4, ring5, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, armorLeather, armorMail, gloveFencing, gloveGauntlet, gloveJousting, buckler, shield, dagger, daggerDropBestWeapon, hammer, hammerParalyze, hammerSpark, sword, swordImpress, swordNullify, halberd, halberdPushActor, wand1, wand2, gem1, gem2, gem3, currency] + [dart, dart200, paralizingProj, harpoon, net, jumpingPole, sharpeningTool, seeingItem, light1, light2, light3, gorget, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, necklace8, necklace9, sightSharpening, ring1, ring2, ring3, ring4, ring5, ring6, ring7, ring8, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, scroll11, armorLeather, armorMail, gloveFencing, gloveGauntlet, gloveJousting, buckler, shield, dagger, daggerDropBestWeapon, hammer, hammerParalyze, hammerSpark, sword, swordImpress, swordNullify, halberd, halberdPushActor, wand1, wand2, gem1, gem2, gem3, gem4, currency] -dart, dart200, bolas, harpoon, net, jumpingPole, whetstone, woodenTorch, oilLamp, brassLantern, gorget, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, monocle, ring1, ring2, ring3, ring4, ring5, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, armorLeather, armorMail, gloveFencing, gloveGauntlet, gloveJousting, buckler, shield, dagger, daggerDropBestWeapon, hammer, hammerParalyze, hammerSpark, sword, swordImpress, swordNullify, halberd, halberdPushActor, wand1, wand2, gem1, gem2, gem3, currency :: ItemKind +dart, dart200, paralizingProj, harpoon, net, jumpingPole, sharpeningTool, seeingItem, light1, light2, light3, gorget, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, necklace8, necklace9, sightSharpening, ring1, ring2, ring3, ring4, ring5, ring6, ring7, ring8, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, flask1, flask2, flask3, flask4, flask5, flask6, flask7, flask8, flask9, flask10, flask11, flask12, flask13, flask14, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, scroll10, scroll11, armorLeather, armorMail, gloveFencing, gloveGauntlet, gloveJousting, buckler, shield, dagger, daggerDropBestWeapon, hammer, hammerParalyze, hammerSpark, sword, swordImpress, swordNullify, halberd, halberdPushActor, wand1, wand2, gem1, gem2, gem3, gem4, currency :: ItemKind necklace, ring, potion, flask, scroll, wand, gem :: ItemKind -- generic templates @@ -56,7 +58,7 @@ symbolHafted = ')' symbolWand = '/' -- magical rod, transmitter, pistol, rifle _symbolStaff = '_' -- scanner -_symbolFood = ',' +_symbolFood = ',' -- too easy to miss? -- * Thrown weapons @@ -65,12 +67,12 @@ , iname = "dart" , ifreq = [("useful", 100), ("any arrow", 100)] , iflavour = zipPlain [Cyan] - , icount = 3 * d 3 - , irarity = [(1, 20), (10, 10)] - , iverbHit = "prick" + , icount = 4 * d 3 + , irarity = [(1, 10), (10, 20)] + , iverbHit = "nick" , iweight = 50 - , iaspects = [AddHurtRanged ((d 6 + dl 6) |*| 10)] - , ieffects = [Hurt (3 * d 1)] + , iaspects = [AddHurtRanged (d 3 + dl 6 |*| 20)] + , ieffects = [Hurt (2 * d 1)] , ifeature = [Identified] , idesc = "Little, but sharp and sturdy." -- "Much inferior to arrows though, especially given the contravariance problems." --- funny, but destroy the suspension of disbelief; this is supposed to be a Lovecraftian horror and any hilarity must ensue from the failures in making it so and not from actively trying to be funny; also, mundane objects are not supposed to be scary or transcendental; the scare is in horrors from the abstract dimension visiting our ordinary reality; without the contrast there's no horror and no wonder, so also the magical items must be contrasted with ordinary XIX century and antique items , ikit = [] @@ -80,12 +82,12 @@ , iname = "fine dart" , ifreq = [("useful", 100), ("any arrow", 50)] -- TODO: until arrows added , iflavour = zipPlain [BrRed] - , icount = 3 * d 3 - , irarity = [(4, 20), (10, 10)] + , icount = 4 * d 3 + , irarity = [(1, 20), (10, 10)] , iverbHit = "prick" , iweight = 50 - , iaspects = [AddHurtRanged ((d 6 + dl 6) |*| 10)] - , ieffects = [Hurt (2 * d 1)] + , iaspects = [AddHurtRanged (d 3 + dl 6 |*| 20)] + , ieffects = [Hurt (1 * d 1)] , ifeature = [toVelocity 200, Identified] , idesc = "Finely balanced for throws of great speed." , ikit = [] @@ -93,7 +95,7 @@ -- * Exotic thrown weapons -bolas = ItemKind +paralizingProj = ItemKind { isymbol = symbolProjectile , iname = "bolas set" , ifreq = [("useful", 100)] @@ -105,7 +107,7 @@ , iaspects = [] , ieffects = [Hurt (2 * d 1), Paralyze (5 + d 5), DropBestWeapon] , ifeature = [Identified] - , idesc = "Wood balls tied with hemp rope. The target enemy is tripped and bound to drop its weapon, while recovering balance." + , idesc = "Wood balls tied with hemp rope. The target enemy is tripped and bound to drop the main weapon, while fighting for balance." , ikit = [] } harpoon = ItemKind @@ -117,7 +119,7 @@ , irarity = [(10, 10)] , iverbHit = "hook" , iweight = 4000 - , iaspects = [AddHurtRanged ((d 2 + 2 * dl 5) |*| 10)] + , iaspects = [AddHurtRanged (d 2 + dl 5 |*| 20)] , ieffects = [Hurt (4 * d 1), PullActor (ThrowMod 200 50)] , ifeature = [] , idesc = "The cruel, barbed head lodges in its victim so painfully that the weakest tug of the thin line sends the victim flying." @@ -151,13 +153,13 @@ , irarity = [(1, 2), (10, 1)] , iverbHit = "prod" , iweight = 10000 - , iaspects = [Timeout $ (d 2 + 2 - dl 2) |*| 10] + , iaspects = [Timeout $ d 2 + 2 - dl 2 |*| 10] , ieffects = [Recharging (toOrganActorTurn "fast 20" 1)] , ifeature = [Durable, Applicable, Identified] , idesc = "Makes you vulnerable at take-off, but then you are free like a bird." , ikit = [] } -whetstone = ItemKind +sharpeningTool = ItemKind { isymbol = symbolTool , iname = "whetstone" , ifreq = [("useful", 100)] @@ -172,32 +174,49 @@ , 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." , ikit = [] } +seeingItem = ItemKind + { isymbol = '%' + , iname = "pupil" + , ifreq = [("useful", 100)] + , iflavour = zipPlain [Red] + , icount = 1 + , irarity = [(10, 1)] + , iverbHit = "gaze at" + , iweight = 100 + , iaspects = [ AddSight 10, AddMaxCalm 60, AddLight 2 + , Periodic, Timeout $ 1 + d 2 ] + , ieffects = [ Recharging (toOrganNone "poisoned") + , Recharging (Summon [("mobile monster", 1)] 1) ] + , ifeature = [Identified] + , idesc = "A slimy, dilated green pupil torn out from some giant eye. Clear and focused, as if still alive." + , ikit = [] + } -- * Lights -woodenTorch = ItemKind +light1 = ItemKind { isymbol = symbolLight , iname = "wooden torch" , ifreq = [("useful", 100), ("light source", 100)] , iflavour = zipPlain [Brown] - , icount = 1 - , irarity = [(1, 8), (3, 6)] + , icount = 1 + d 3 + , irarity = [(1, 8)] , iverbHit = "scorch" , iweight = 1200 - , iaspects = [ AddLight 3 - , AddSight (-2) ] -- not only flashes, but also sparks - , ieffects = [Burn 3] + , iaspects = [ AddLight 3 -- not only flashes, but also sparks + , AddSight (-2) ] -- unused by AI due to the mixed blessing + , ieffects = [Burn 2] , ifeature = [EqpSlot EqpSlotAddLight "", Identified] - , idesc = "A smoking, heavy wooden torch, burning in an unsteady fire." + , idesc = "A smoking, heavy wooden torch, burning in an unsteady glow." , ikit = [] } -oilLamp = ItemKind +light2 = ItemKind { isymbol = symbolLight , iname = "oil lamp" , ifreq = [("useful", 100), ("light source", 100)] , iflavour = zipPlain [BrYellow] , icount = 1 - , irarity = [(5, 5), (10, 5)] + , irarity = [(7, 10)] , iverbHit = "burn" , iweight = 1000 , iaspects = [AddLight 3, AddSight (-1)] @@ -207,13 +226,13 @@ , idesc = "A clay lamp filled with plant oil feeding a tiny wick." , ikit = [] } -brassLantern = ItemKind +light3 = ItemKind { isymbol = symbolLight , iname = "brass lantern" , ifreq = [("useful", 100), ("light source", 100)] , iflavour = zipPlain [BrWhite] , icount = 1 - , irarity = [(10, 4)] + , irarity = [(10, 3)] , iverbHit = "burn" , iweight = 2400 , iaspects = [AddLight 4, AddSight (-1)] @@ -228,20 +247,21 @@ gorget = ItemKind { isymbol = symbolNecklace - , iname = "gorget" + , iname = "Old Gorget" , ifreq = [("useful", 100)] , iflavour = zipFancy [BrCyan] , icount = 1 - , irarity = [(4, 1), (10, 2)] + , irarity = [(4, 3), (10, 3)] -- weak, shallow , iverbHit = "whip" , iweight = 30 - , iaspects = [ Periodic - , Timeout $ (d 3 + 3 - dl 3) |*| 10 - , AddArmorMelee 1 - , AddArmorRanged 1 ] + , iaspects = [ Unique + , Periodic + , Timeout $ d 3 + 3 - dl 3 |*| 10 + , AddArmorMelee $ 2 + d 3 + , AddArmorRanged $ 2 + d 3 ] , ieffects = [Recharging (RefillCalm 1)] - , ifeature = [ Durable, Precious, EqpSlot EqpSlotPeriodic "", Identified - , toVelocity 50 ] -- not dense enough + , ifeature = [ Durable, Precious, EqpSlot EqpSlotPeriodic "" + , Identified, toVelocity 50 ] -- not dense enough , idesc = "Highly ornamental, cold, large, steel medallion on a chain. Unlikely to offer much protection as an armor piece, but the old, worn engraving reassures you." , ikit = [] } @@ -251,7 +271,7 @@ , ifreq = [("useful", 100)] , iflavour = zipFancy stdCol ++ zipPlain brightCol , icount = 1 - , irarity = [(10, 3)] + , irarity = [(10, 2)] , iverbHit = "whip" , iweight = 30 , iaspects = [Periodic] @@ -262,55 +282,74 @@ , ikit = [] } necklace1 = necklace - { iaspects = (Timeout $ (d 3 + 4 - dl 3) |*| 10) : iaspects necklace - , ieffects = [Recharging (RefillHP 1)] - , idesc = "A cord of dried herbs and healing berries." + { ifreq = [("treasure", 100)] + , iaspects = [Unique, Timeout $ d 3 + 4 - dl 3 |*| 10] + ++ iaspects necklace + , ieffects = [NoEffect "of Aromata", Recharging (RefillHP 1)] + , ifeature = Durable : ifeature necklace + , idesc = "A cord of freshly dried herbs and healing berries." } necklace2 = necklace - { irarity = [(2, 0), (10, 1)] - , iaspects = (Timeout $ (d 3 + 3 - dl 3) |*| 10) : iaspects necklace - , ieffects = [ Recharging (Impress) + { ifreq = [("treasure", 100)] -- just too nasty to call it useful + , irarity = [(10, 1)] + , iaspects = (Timeout $ d 3 + 3 - dl 3 |*| 10) : iaspects necklace + , ieffects = [ Recharging Impress , Recharging (DropItem COrgan "temporary conditions" True) , Recharging (Summon [("mobile animal", 1)] $ 1 + dl 2) , Recharging (Explode "waste") ] } necklace3 = necklace - { iaspects = (Timeout $ (d 3 + 3 - dl 3) |*| 10) : iaspects necklace + { iaspects = (Timeout $ d 3 + 3 - dl 3 |*| 10) : iaspects necklace , ieffects = [Recharging (Paralyze $ 5 + d 5 + dl 5)] } necklace4 = necklace - { iaspects = (Timeout $ (d 4 + 4 - dl 4) |*| 2) : iaspects necklace - , ieffects = [Recharging (Teleport $ d 3 |*| 3)] + { iaspects = (Timeout $ d 4 + 4 - dl 4 |*| 2) : iaspects necklace + , ieffects = [Recharging (Teleport $ d 2 * 3)] } necklace5 = necklace - { iaspects = (Timeout $ (d 3 + 4 - dl 3) |*| 10) : iaspects necklace - , ieffects = [Recharging (Teleport $ 12 + d 3 |*| 3)] + { iaspects = (Timeout $ d 3 + 4 - dl 3 |*| 10) : iaspects necklace + , ieffects = [Recharging (Teleport $ 14 + d 3 * 3)] } necklace6 = necklace { iaspects = (Timeout $ d 4 |*| 10) : iaspects necklace , ieffects = [Recharging (PushActor (ThrowMod 100 50))] } necklace7 = necklace -- TODO: teach AI to wear only for fight - { irarity = [(4, 0), (10, 2)] - , iaspects = [AddSpeed $ d 2, Timeout $ (d 3 + 3 + dl 3) |*| 2] + { ifreq = [("treasure", 100)] + , iaspects = [ Unique, AddMaxHP $ 10 + d 10 + , AddArmorMelee 20, AddArmorRanged 20 + , Timeout $ d 2 + 5 - dl 3 ] ++ iaspects necklace - , ieffects = [Recharging (RefillHP (-1))] + , ieffects = [ NoEffect "of Overdrive" + , Recharging (InsertMove $ 1 + d 2) + , Recharging (RefillHP (-1)) + , Recharging (RefillCalm (-1)) ] + , ifeature = Durable : ifeature necklace } +necklace8 = necklace + { iaspects = (Timeout $ d 3 + 3 - dl 3 |*| 5) : iaspects necklace + , ieffects = [Recharging $ Explode "spark"] + } +necklace9 = necklace + { iaspects = (Timeout $ d 3 + 3 - dl 3 |*| 5) : iaspects necklace + , ieffects = [Recharging $ Explode "fragrance"] + } -- * Non-periodic jewelry -monocle = ItemKind +sightSharpening = ItemKind { isymbol = symbolRing - , iname = "monocle" - , ifreq = [("useful", 100)] + , iname = "Sharp Monocle" + , ifreq = [("treasure", 100)] , iflavour = zipPlain [White] , icount = 1 - , irarity = [(5, 0), (10, 1)] + , irarity = [(7, 3), (10, 3)] -- medium weak, medium shallow , iverbHit = "rap" , iweight = 50 - , iaspects = [AddSight $ d 2, AddHurtMelee $ d 2 |*| 3] + , iaspects = [Unique, AddSight $ 1 + d 2, AddHurtMelee $ d 2 |*| 3] , ieffects = [] - , ifeature = [Precious, Identified, Durable, EqpSlot EqpSlotAddSight ""] + , ifeature = [ Precious, Identified, Durable + , EqpSlot EqpSlotAddSight "" ] , idesc = "Let's you better focus your weaker eye." , ikit = [] } @@ -334,33 +373,57 @@ } ring1 = ring { irarity = [(10, 2)] - , iaspects = [AddSpeed $ d 2, AddMaxHP $ dl 3 - 5 - d 3] + , iaspects = [AddSpeed $ d 2, AddMaxHP $ dl 5 - 5 - d 5] , ieffects = [Explode "distortion"] -- strong magic , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddSpeed ""] } ring2 = ring - { iaspects = [AddMaxHP $ 3 + dl 5, AddMaxCalm $ dl 6 - 15 - d 6] + { iaspects = [AddMaxHP $ 10 + dl 10, AddMaxCalm $ dl 5 - 20 - d 5] , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddMaxHP ""] } ring3 = ring - { iaspects = [AddMaxCalm $ 10 + dl 10] + { iaspects = [AddMaxCalm $ 15 + dl 15] , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddMaxCalm ""] , idesc = "Cold, solid to the touch, perfectly round, engraved with solemn, strangely comforting, worn out words." } ring4 = ring { irarity = [(3, 6), (10, 6)] - , iaspects = [AddHurtMelee $ (d 5 + dl 5) |*| 3, AddMaxHP $ dl 3 - 4 - d 2] + , iaspects = [AddHurtMelee $ d 5 + dl 5 |*| 3, AddMaxHP $ dl 3 - 5 - d 3] , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddHurtMelee ""] } ring5 = ring -- by the time it's found, probably no space in eqp - { irarity = [(5, 0)] + { irarity = [(5, 0), (10, 1)] , iaspects = [AddLight $ d 2] , ieffects = [Explode "distortion"] -- strong magic , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddLight ""] , idesc = "A sturdy ring with a large, shining stone." } +ring6 = ring + { ifreq = [("treasure", 100)] + , irarity = [(10, 2)] + , iaspects = [ Unique, AddSpeed $ 3 + d 4 + , AddMaxCalm $ - 20 - d 20, AddMaxHP $ - 20 - d 20 ] + , ieffects = [NoEffect "of Rush"] -- no explosion, because Durable + , ifeature = ifeature ring ++ [Durable, EqpSlot EqpSlotAddSpeed ""] + } +ring7 = ring + { ifreq = [("useful", 100), ("ring of opportunity sniper", 1) ] + , irarity = [(10, 1)] + , iaspects = [AddSkills $ EM.fromList [(AbProject, 9)]] + , ieffects = [ NoEffect "of opportunity sniper" + , Explode "distortion" ] -- strong magic + , ifeature = ifeature ring ++ [EqpSlot (EqpSlotAddSkills AbProject) ""] + } +ring8 = ring + { ifreq = [("useful", 1), ("ring of opportunity grenadier", 1) ] + , irarity = [(10, 1)] + , iaspects = [AddSkills $ EM.fromList [(AbProject, 11)]] + , ieffects = [ NoEffect "of opportunity grenadier" + , Explode "distortion" ] -- strong magic + , ifeature = ifeature ring ++ [EqpSlot (EqpSlotAddSkills AbProject) ""] + } --- * Exploding consumables, often intended to be thrown +-- * Ordinary exploding consumables, often intended to be thrown potion = ItemKind { isymbol = symbolPotion @@ -379,24 +442,28 @@ , ikit = [] } potion1 = potion - { ieffects = [ NoEffect "of rose water", Impress - , OnSmash (ApplyPerfume), OnSmash (Explode "fragrance") ] + { ieffects = [ NoEffect "of rose water", Impress, RefillCalm (-3) + , OnSmash ApplyPerfume, OnSmash (Explode "fragrance") ] } potion2 = potion - { ifreq = [("useful", 10)] -- extremely rare - , irarity = [(1, 1)] - , ieffects = [ NoEffect "of attraction", OnSmash (Explode "pheromone")] + { ifreq = [("treasure", 100)] + , irarity = [(6, 10), (10, 10)] + , iaspects = [Unique] + , ieffects = [ NoEffect "of Attraction", Impress, OverfillCalm (-20) + , OnSmash (Explode "pheromone") ] } potion3 = potion - { irarity = [(1, 5), (10, 5)] - , ieffects = [RefillHP 5, OnSmash (Explode "healing mist")] + { irarity = [(1, 10)] + , ieffects = [ RefillHP 5, DropItem COrgan "poisoned" True + , OnSmash (Explode "healing mist") ] } potion4 = potion - { irarity = [(10, 5)] - , ieffects = [RefillHP 10, OnSmash (Explode "healing mist 2")] + { irarity = [(10, 10)] + , ieffects = [ RefillHP 10, DropItem COrgan "poisoned" True + , OnSmash (Explode "healing mist 2") ] } potion5 = potion - { ieffects = [ OneOf [Impress, DropBestWeapon, RefillHP 5, Burn 3] + { ieffects = [ OneOf [ Impress, OverfillHP 10, OverfillHP 5, Burn 5 ] , OnSmash (OneOf [ Explode "healing mist" , Explode "wounding mist" , Explode "fragrance" @@ -404,24 +471,37 @@ } potion6 = potion { irarity = [(3, 3), (10, 6)] - , ieffects = [ OneOf [ Dominate, DropBestWeapon, RefillHP 20, Burn 9 - , InsertMove 4 ] + , ieffects = [ Impress + , OneOf [ OverfillCalm (-60) + , toOrganActorTurn "fast 20" (20 + d 5) + , OverfillHP 20, OverfillHP 10, Burn 10 ] , OnSmash (OneOf [ Explode "healing mist 2" - , Explode "healing mist 2" - , Explode "pheromone" + , Explode "calming mist" + , Explode "distressing odor" , Explode "distortion" -- outlier, OK , Explode "blast 20" ]) ] } potion7 = potion - { ieffects = [ DropItem COrgan "poisoned" True, RefillHP 1 + { irarity = [(1, 15), (10, 5)] + , ieffects = [ DropItem COrgan "poisoned" True , OnSmash (Explode "antidote mist") ] } potion8 = potion - { ieffects = [ DropItem COrgan "temporary conditions" True, RefillHP 2 + { irarity = [(1, 5), (10, 15)] + , ieffects = [ DropItem COrgan "temporary conditions" True , OnSmash (Explode "blast 10") ] } +potion9 = potion + { ifreq = [("treasure", 100)] + , irarity = [(10, 5)] + , iaspects = [Unique] + , ieffects = [ NoEffect "of Love", OverfillHP 60 + , Impress, OverfillCalm (-60) + , OnSmash (Explode "healing mist 2") + , OnSmash (Explode "pheromone") ] + } --- * Exploding consumables, with temporary aspects +-- * Exploding consumables with temporary aspects, can be thrown -- TODO: dip projectiles in those -- TODO: add flavour and realism as in, e.g., "flask of whiskey", -- which is more flavourful and believable than "flask of strength" @@ -429,7 +509,7 @@ flask = ItemKind { isymbol = symbolFlask , iname = "flask" - , ifreq = [("useful", 100)] + , ifreq = [("useful", 100), ("flask", 100)] , iflavour = zipLiquid darkCol ++ zipPlain darkCol ++ zipFancy darkCol , icount = 1 , irarity = [(1, 9), (10, 6)] @@ -446,6 +526,7 @@ { irarity = [(10, 5)] , ieffects = [ NoEffect "of strength brew" , toOrganActorTurn "strengthened" (20 + d 5) + , toOrganNone "regenerating" , OnSmash (Explode "strength mist") ] } flask2 = flask @@ -459,9 +540,9 @@ , OnSmash (Explode "protecting balm") ] } flask4 = flask - { ieffects = [ NoEffect "of red paint" - , toOrganGameTurn "painted red" (20 + d 5) - , OnSmash (Explode "red paint") ] + { ieffects = [ NoEffect "of PhD defense questions" + , toOrganGameTurn "defenseless" (20 + d 5) + , OnSmash (Explode "PhD defense question") ] } flask5 = flask { irarity = [(10, 5)] @@ -473,6 +554,7 @@ { ieffects = [ NoEffect "of lethargy brew" , toOrganGameTurn "slow 10" (20 + d 5) , toOrganNone "regenerating" + , RefillCalm 3 , OnSmash (Explode "slowness spray") ] } flask7 = flask -- sight can be reduced from Calm, drunk, etc. @@ -488,16 +570,20 @@ , OnSmash (Explode "smelly droplet") ] } flask9 = flask - { ieffects = [ NoEffect "of bait cocktail", toOrganActorTurn "drunk" (5 + d 5) + { ieffects = [ NoEffect "of bait cocktail" + , toOrganActorTurn "drunk" (5 + d 5) + , Impress , OnSmash (Summon [("mobile animal", 1)] $ 1 + dl 2) , OnSmash (Explode "waste") ] } flask10 = flask - { ieffects = [ NoEffect "of whiskey", toOrganActorTurn "drunk" (20 + d 5) - , Burn 2, RefillHP 4, OnSmash (Explode "whiskey spray") ] + { ieffects = [ NoEffect "of whiskey" + , toOrganActorTurn "drunk" (20 + d 5) + , Impress, Burn 2, RefillHP 4 + , OnSmash (Explode "whiskey spray") ] } flask11 = flask - { irarity = [(1, 20), (10, 6)] + { irarity = [(1, 20), (10, 10)] , ieffects = [ NoEffect "of regeneration brew" , toOrganNone "regenerating" , OnSmash (Explode "healing mist") ] @@ -513,7 +599,7 @@ , toOrganNone "slow resistant" , OnSmash (Explode "anti-slow mist") ] } -flask14 = flask -- but not flask of Calm depletion, since Calm reduced often +flask14 = flask { irarity = [(10, 5)] , ieffects = [ NoEffect "of poison resistance" , toOrganNone "poison resistant" @@ -539,29 +625,31 @@ , ikit = [] } scroll1 = scroll - { irarity = [(3, 6), (10, 6)] - , ieffects = [CallFriend 1] + { ifreq = [("treasure", 100)] + , irarity = [(5, 10), (10, 10)] -- mixed blessing, so available early + , iaspects = [Unique] + , ieffects = [ NoEffect "of Reckless Beacon" + , CallFriend 1, Summon standardSummon (2 + d 2) ] } scroll2 = scroll - { irarity = [(1, 7), (10, 5)] - , ieffects = [NoEffect "of fireworks", Explode "firecracker 7"] + { irarity = [] + , ieffects = [] } scroll3 = scroll { irarity = [(1, 5), (10, 3)] , ieffects = [Ascend (-1)] } scroll4 = scroll - { ieffects = [OneOf [ Teleport $ d 3 |*| 3, RefillCalm 10, RefillCalm (-10) - , InsertMove 3, Paralyze 10, Identify CGround ]] + { ieffects = [OneOf [ Teleport 5, RefillCalm 5, RefillCalm (-5) + , InsertMove 5, Paralyze 10 ]] } scroll5 = scroll { irarity = [(10, 15)] - , ieffects = [OneOf [ Summon standardSummon $ d 2 - , CallFriend (d 2), Ascend (-1), Ascend 1 - , RefillCalm 30, RefillCalm (-30) - , CreateItem CGround "useful" TimerNone - , PolyItem CGround ]] - -- TODO: ask player: Escape 1 + , ieffects = [ Impress + , OneOf [ Teleport 20, Ascend (-1), Ascend 1 + , Summon standardSummon 2, CallFriend 1 + , RefillCalm 5, OverfillCalm (-60) + , CreateItem CGround "useful" TimerNone ] ] } scroll6 = scroll { ieffects = [Teleport 5] @@ -573,17 +661,26 @@ { irarity = [(10, 3)] , ieffects = [InsertMove $ 1 + d 2 + dl 2] } -scroll9 = scroll - { irarity = [(1, 15)] - , ieffects = [Identify CGround] -- TODO: ask player: AskPlayer cstore eff? +scroll9 = scroll -- TODO: remove Calm when server can tell if anything IDed + { irarity = [(1, 15), (10, 10)] + , ieffects = [ NoEffect "of scientific explanation" + , Identify, OverfillCalm 3 ] } -scroll10 = scroll +scroll10 = scroll -- TODO: firecracker only if an item really polymorphed? + -- But currently server can't tell. { irarity = [(10, 10)] - , ieffects = [PolyItem CGround] + , ieffects = [ NoEffect "transfiguration" + , PolyItem, Explode "firecracker 7" ] } +scroll11 = scroll + { ifreq = [("treasure", 100)] + , irarity = [(6, 10), (10, 10)] + , iaspects = [Unique] + , ieffects = [NoEffect "of Prisoner Release", CallFriend 1] + } standardSummon :: Freqs ItemKind -standardSummon = [("monster", 30), ("mobile animal", 70)] +standardSummon = [("mobile monster", 30), ("mobile animal", 70)] -- * Armor @@ -597,8 +694,8 @@ , iverbHit = "thud" , iweight = 7000 , iaspects = [ AddHurtMelee (-3) - , AddArmorMelee $ (d 2 + dl 3) |*| 5 - , AddArmorRanged $ (d 2 + dl 3) |*| 5 ] + , AddArmorMelee $ 1 + d 2 + dl 2 |*| 5 + , AddArmorRanged $ 1 + d 2 + dl 2 |*| 5 ] , ieffects = [] , ifeature = [ toVelocity 30 -- unwieldy to throw and blunt , Durable, EqpSlot EqpSlotAddArmorMelee "", Identified ] @@ -611,8 +708,8 @@ , irarity = [(6, 9), (10, 3)] , iweight = 12000 , iaspects = [ AddHurtMelee (-3) - , AddArmorMelee $ (1 + d 2 + dl 4) |*| 5 - , AddArmorRanged $ (1 + d 2 + dl 4) |*| 5 ] + , AddArmorMelee $ 2 + d 2 + dl 3 |*| 5 + , AddArmorRanged $ 2 + d 2 + dl 3 |*| 5 ] , idesc = "A long shirt woven from iron rings. Discourages foes from attacking your torso, making it harder for them to land a blow." } gloveFencing = ItemKind @@ -637,18 +734,19 @@ , iflavour = zipPlain [BrCyan] , irarity = [(1, 9), (10, 3)] , iweight = 300 - , iaspects = [ AddArmorMelee $ (1 + dl 2) |*| 5 - , AddArmorRanged $ (1 + dl 2) |*| 5 ] + , iaspects = [ AddArmorMelee $ 1 + dl 2 |*| 5 + , AddArmorRanged $ 1 + dl 2 |*| 5 ] , idesc = "Long leather gauntlet covered in overlapping steel plates." } gloveJousting = gloveFencing - { iname = "jousting gauntlet" + { iname = "Tournament Gauntlet" , iflavour = zipFancy [BrRed] , irarity = [(1, 3), (10, 3)] , iweight = 500 - , iaspects = [ AddHurtMelee $ (dl 4 - 6) |*| 3 - , AddArmorMelee $ (2 + dl 2) |*| 5 - , AddArmorRanged $ (2 + dl 2) |*| 5 ] + , iaspects = [ Unique + , AddHurtMelee $ dl 4 - 6 |*| 3 + , AddArmorMelee $ 2 + dl 2 |*| 5 + , AddArmorRanged $ 2 + dl 2 |*| 5 ] , idesc = "Rigid, steel, jousting handgear. If only you had a lance. And a horse." } @@ -667,23 +765,24 @@ , iweight = 2000 , iaspects = [ AddArmorMelee 40 , AddHurtMelee (-30) - , Timeout $ (d 3 + 3 - dl 3) |*| 2 ] - , ieffects = [] -- [Recharging (PushActor (ThrowMod 200 50))] - , ifeature = [ toVelocity 30 -- unwieldy to throw and blunt + , Timeout $ d 3 + 3 - dl 3 |*| 2 ] + , ieffects = [ Hurt (1 * d 1) -- to display xdy everywhre in Hurt + , Recharging (PushActor (ThrowMod 200 50)) ] + , ifeature = [ toVelocity 40 -- unwieldy to throw , Durable, EqpSlot EqpSlotAddArmorMelee "", Identified ] , idesc = "Heavy and unwieldy. Absorbs a percentage of melee damage, both dealt and sustained. Too small to intercept projectiles with." , ikit = [] } shield = buckler { iname = "shield" - , irarity = [(7, 5)] + , irarity = [(8, 3)] , iflavour = zipPlain [Green] , iweight = 3000 , iaspects = [ AddArmorMelee 80 , AddHurtMelee (-70) - , Timeout $ (d 3 + 6 - dl 3) |*| 2 ] - , ieffects = [] -- [Recharging (PushActor (ThrowMod 400 50))] - , ifeature = [ toVelocity 20 -- unwieldy to throw and blunt + , Timeout $ d 6 + 6 - dl 6 |*| 2 ] + , ieffects = [Hurt (1 * d 1), Recharging (PushActor (ThrowMod 400 50))] + , ifeature = [ toVelocity 30 -- unwieldy to throw , Durable, EqpSlot EqpSlotAddArmorMelee "", Identified ] , idesc = "Large and unwieldy. Absorbs a percentage of melee damage, both dealt and sustained. Too heavy to intercept projectiles with." } @@ -696,10 +795,12 @@ , ifreq = [("useful", 100), ("starting weapon", 100)] , iflavour = zipPlain [BrCyan] , icount = 1 - , irarity = [(1, 12), (10, 4)] + , irarity = [(1, 20), (10, 1)] , iverbHit = "stab" , iweight = 1000 - , iaspects = [AddHurtMelee $ (d 3 + dl 3) |*| 3, AddArmorMelee $ d 2 |*| 5] + , iaspects = [ AddHurtMelee $ d 3 + dl 3 |*| 3 + , AddArmorMelee $ d 2 |*| 5 + , AddHurtRanged (-60) ] -- as powerful as a dart , ieffects = [Hurt (6 * d 1)] , ifeature = [ toVelocity 40 -- ensuring it hits with the tip costs speed , Durable, EqpSlot EqpSlotWeapon "", Identified ] @@ -707,8 +808,9 @@ , ikit = [] } daggerDropBestWeapon = dagger - { ifreq = [("useful", 30)] - , irarity = [(1, 1), (10, 2)] + { iname = "Double Dagger" + , ifreq = [("treasure", 20)] + , irarity = [(1, 2), (10, 4)] -- The timeout has to be small, so that the player can count on the effect -- occuring consistently in any longer fight. Otherwise, the effect will be -- absent in some important fights, leading to the feeling of bad luck, @@ -717,8 +819,9 @@ -- 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] - , ieffects = ieffects dagger ++ [Recharging DropBestWeapon] + , iaspects = [Unique, Timeout $ d 3 + 4 - dl 3 |*| 2] + , ieffects = ieffects dagger + ++ [Recharging DropBestWeapon, Recharging $ RefillCalm (-3)] , idesc = "A double dagger that a focused fencer can use to catch and twist an opponent's blade occasionally." } hammer = ItemKind @@ -727,10 +830,11 @@ , ifreq = [("useful", 100), ("starting weapon", 100)] , iflavour = zipPlain [BrMagenta] , icount = 1 - , irarity = [(4, 12), (10, 2)] + , irarity = [(5, 15)] , iverbHit = "club" , iweight = 1500 - , iaspects = [AddHurtMelee $ (d 2 + dl 2) |*| 3] + , iaspects = [ AddHurtMelee $ d 2 + dl 2 |*| 3 + , AddHurtRanged (-80) ] -- as powerful as a dart , ieffects = [Hurt (8 * d 1)] , ifeature = [ toVelocity 20 -- ensuring it hits with the sharp tip costs , Durable, EqpSlot EqpSlotWeapon "", Identified ] @@ -738,16 +842,17 @@ , ikit = [] } hammerParalyze = hammer - { ifreq = [("useful", 30)] - , irarity = [(4, 1), (10, 2)] - , iaspects = iaspects hammer ++ [Timeout $ (d 2 + 3 - dl 2) |*| 2] + { iname = "Concussion Hammer" + , ifreq = [("treasure", 20)] + , irarity = [(5, 2), (10, 4)] + , iaspects = [Unique, Timeout $ d 2 + 3 - dl 2 |*| 2] , ieffects = ieffects hammer ++ [Recharging $ Paralyze 5] } hammerSpark = hammer - { iname = "smithhammer" - , ifreq = [("useful", 30)] - , irarity = [(4, 1), (10, 2)] - , iaspects = iaspects hammer ++ [Timeout $ (d 4 + 4 - dl 4) |*| 2] + { iname = "Grand Smithhammer" + , ifreq = [("treasure", 20)] + , irarity = [(5, 2), (10, 4)] + , iaspects = [Unique, Timeout $ d 4 + 4 - dl 4 |*| 2] , ieffects = ieffects hammer ++ [Recharging $ Explode "spark"] } sword = ItemKind @@ -756,29 +861,32 @@ , ifreq = [("useful", 100), ("starting weapon", 100)] , iflavour = zipPlain [BrBlue] , icount = 1 - , irarity = [(3, 1), (6, 16), (10, 8)] + , irarity = [(4, 1), (5, 15)] , iverbHit = "slash" , iweight = 2000 , iaspects = [] , ieffects = [Hurt (10 * d 1)] - , ifeature = [ toVelocity 20 -- ensuring it hits with the tip costs speed + , ifeature = [ toVelocity 5 -- ensuring it hits with the tip costs speed , Durable, EqpSlot EqpSlotWeapon "", Identified ] , idesc = "Difficult to master; deadly when used effectively. The steel is particularly hard and keen, but rusts quickly without regular maintenance." , ikit = [] } swordImpress = sword - { ifreq = [("useful", 30)] - , irarity = [(3, 1), (10, 2)] - , iaspects = iaspects sword ++ [Timeout $ (d 4 + 5 - dl 4) |*| 2] + { iname = "Master's Sword" + , ifreq = [("treasure", 20)] + , irarity = [(5, 1), (10, 4)] + , iaspects = [Unique, Timeout $ d 4 + 5 - dl 4 |*| 2] , ieffects = ieffects sword ++ [Recharging Impress] , idesc = "A particularly well-balance blade, lending itself to impressive shows of fencing skill." } swordNullify = sword - { ifreq = [("useful", 30)] - , irarity = [(3, 0), (10, 1)] - , iaspects = iaspects sword ++ [Timeout $ (d 4 + 5 - dl 4) |*| 2] + { iname = "Gutting Sword" + , ifreq = [("treasure", 20)] + , irarity = [(5, 1), (10, 4)] + , iaspects = [Unique, Timeout $ d 4 + 5 - dl 4 |*| 2] , ieffects = ieffects sword - ++ [Recharging $ DropItem COrgan "temporary conditions" True] + ++ [ Recharging $ DropItem COrgan "temporary conditions" True + , Recharging $ RefillHP (-2) ] , idesc = "Cold, thin blade that pierces deeply and sends its victim into abrupt, sobering shock." } halberd = ItemKind @@ -790,18 +898,18 @@ , irarity = [(7, 1), (10, 10)] , iverbHit = "impale" , iweight = 3000 - , iaspects = [AddArmorMelee $ (1 + dl 3) |*| 5] + , iaspects = [AddArmorMelee $ 1 + dl 3 |*| 5] , ieffects = [Hurt (12 * d 1)] - , ifeature = [ toVelocity 20 -- not balanced + , ifeature = [ toVelocity 5 -- not balanced , Durable, EqpSlot EqpSlotWeapon "", Identified ] , idesc = "An improvised but deadly weapon made of a blade from a scythe attached to a long pole." , ikit = [] } halberdPushActor = halberd - { iname = "halberd" - , ifreq = [("useful", 30)] - , irarity = [(7, 1), (10, 2)] - , iaspects = iaspects halberd ++ [Timeout $ (d 5 + 5 - dl 5) |*| 2] + { iname = "Swiss Halberd" + , ifreq = [("treasure", 20)] + , irarity = [(7, 1), (10, 4)] + , iaspects = [Unique, Timeout $ d 5 + 5 - dl 5 |*| 2] , ieffects = ieffects halberd ++ [Recharging (PushActor (ThrowMod 400 25))] , idesc = "A versatile polearm, with great reach and leverage. Foes are held at a distance." } @@ -836,7 +944,7 @@ gem = ItemKind { isymbol = symbolGem , iname = "gem" - , ifreq = [("treasure", 100)] + , ifreq = [("treasure", 100), ("gem", 1)] , iflavour = zipPlain $ delete BrYellow brightCol -- natural, so not fancy , icount = 1 , irarity = [] @@ -849,21 +957,30 @@ , ikit = [] } gem1 = gem - { irarity = [(2, 0), (10, 10)] + { irarity = [(2, 0), (10, 12)] } gem2 = gem - { irarity = [(4, 0), (10, 15)] + { irarity = [(4, 0), (10, 14)] } gem3 = gem - { irarity = [(6, 0), (10, 20)] + { irarity = [(6, 0), (10, 16)] } +gem4 = gem + { iname = "elixir" + , iflavour = zipPlain [BrYellow] + , irarity = [(1, 40), (10, 40)] + , iaspects = [] + , ieffects = [NoEffect "of youth", OverfillCalm 5, OverfillHP 15] + , ifeature = [Identified, Precious] -- TODO: only for humans + , idesc = "A crystal vial of amber liquid, supposedly granting eternal youth and fetching 100 gold per piece. The main effect seems to be mild euphoria, but it admittedly heals minor ailments rather well." + } currency = ItemKind { isymbol = symbolGold , iname = "gold piece" , ifreq = [("treasure", 100), ("currency", 1)] , iflavour = zipPlain [BrYellow] , icount = 10 + d 20 + dl 20 - , irarity = [(1, 0), (2, 15), (5, 25), (10, 10)] + , irarity = [(1, 25), (10, 10)] , iverbHit = "tap" , iweight = 31 , iaspects = [] diff --git a/GameDefinition/Content/ItemKindActor.hs b/GameDefinition/Content/ItemKindActor.hs --- a/GameDefinition/Content/ItemKindActor.hs +++ b/GameDefinition/Content/ItemKindActor.hs @@ -11,9 +11,9 @@ actors :: [ItemKind] actors = - [warrior, adventurer, blacksmith, forester, scientist, soldier, clerk, hairdresser, lawyer, peddler, taxCollector, eye, fastEye, nose, elbow, armadillo, gilaMonster, rattlesnake, komodoDragon, hyena, alligator, hornetSwarm, thornbush, geyser] + [warrior, warrior2, warrior3, warrior4, warrior5, soldier, sniper, civilian, civilian2, civilian3, civilian4, civilian5, eye, fastEye, nose, elbow, torsor, goldenJackal, griffonVulture, skunk, armadillo, gilaMonster, rattlesnake, komodoDragon, hyena, alligator, rhinoceros, beeSwarm, hornetSwarm, thornbush, geyserBoiling, geyserArsenic, geyserSulfur] -warrior, adventurer, blacksmith, forester, scientist, soldier, clerk, hairdresser, lawyer, peddler, taxCollector, eye, fastEye, nose, elbow, armadillo, gilaMonster, rattlesnake, komodoDragon, hyena, alligator, hornetSwarm, thornbush, geyser :: ItemKind +warrior, warrior2, warrior3, warrior4, warrior5, soldier, sniper, civilian, civilian2, civilian3, civilian4, civilian5, eye, fastEye, nose, elbow, torsor, goldenJackal, griffonVulture, skunk, armadillo, gilaMonster, rattlesnake, komodoDragon, hyena, alligator, rhinoceros, beeSwarm, hornetSwarm, thornbush, geyserBoiling, geyserArsenic, geyserSulfur :: ItemKind -- * Hunams @@ -28,21 +28,20 @@ , iweight = 80000 , iaspects = [ AddMaxHP 60 -- partially from clothes and assumed first aid , AddMaxCalm 60, AddSpeed 20 - , AddSkills $ EM.fromList [(AbProject, 1), (AbApply, 1)] - -- TODO: on a ring? - , AddSight 3 ] -- not via eyes, but feel, hearing, etc. + , AddSkills $ EM.fromList [(AbProject, 2), (AbApply, 1)] ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" - , ikit = [("fist", COrgan), ("foot", COrgan), ("eye 4", COrgan)] + , ikit = [ ("fist", COrgan), ("foot", COrgan), ("eye 5", COrgan) + , ("sapient brain", COrgan) ] } -adventurer = warrior +warrior2 = warrior { iname = "adventurer" } -blacksmith = warrior +warrior3 = warrior { iname = "blacksmith" } -forester = warrior +warrior4 = warrior { iname = "forester" } -scientist = warrior +warrior5 = warrior { iname = "scientist" } soldier = warrior @@ -50,17 +49,27 @@ , ifreq = [("soldier", 100)] , ikit = ikit warrior ++ [("starting weapon", CEqp)] } +sniper = warrior + { iname = "sniper" + , ifreq = [("sniper", 100)] + , ikit = ikit warrior + ++ [ ("ring of opportunity sniper", CEqp) + , ("any arrow", CInv), ("any arrow", CInv) + , ("any arrow", CInv), ("any arrow", CInv) + , ("flask", CInv), ("light source", CInv) + , ("light source", CInv), ("light source", CInv) ] + } -clerk = warrior +civilian = warrior { iname = "clerk" , ifreq = [("civilian", 100)] } -hairdresser = clerk +civilian2 = civilian { iname = "hairdresser" } -lawyer = clerk +civilian3 = civilian { iname = "lawyer" } -peddler = clerk +civilian4 = civilian { iname = "peddler" } -taxCollector = clerk +civilian5 = civilian { iname = "tax collector" } -- * Monsters @@ -68,76 +77,97 @@ eye = ItemKind { isymbol = 'e' , iname = "reducible eye" - , ifreq = [("monster", 100), ("horror", 100)] - , iflavour = zipPlain [BrRed] + , ifreq = [("monster", 100), ("horror", 100), ("mobile monster", 100)] + , iflavour = zipFancy [BrRed] , icount = 1 , irarity = [(1, 10), (10, 6)] , iverbHit = "thud" , iweight = 80000 - , iaspects = [ AddMaxHP 10, AddMaxCalm 60, AddSpeed 20 - , AddSkills $ EM.fromList [(AbProject, 1), (AbApply, 1)] - , AddSight 4 ] + , iaspects = [ AddMaxHP 16, AddMaxCalm 60, AddSpeed 20 + , AddSkills $ EM.fromList [(AbProject, 2), (AbApply, 1)] ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "Under your stare, it reduces to the bits that define its essence. Under introspection, the bits slow down and solidify into an arbitrary form again. It must be huge inside, for holographic principle to manifest so overtly." -- holographic principle is an anachronism for XIX or most of XX century, but "the cosmological scale effects" is too weak - , ikit = [("lash", COrgan), ("pupil", COrgan)] + , ikit = [ ("lash", COrgan), ("pupil", COrgan) + , ("sapient brain", COrgan) ] } fastEye = ItemKind { isymbol = 'j' , iname = "injective jaw" - , ifreq = [("monster", 100), ("horror", 100)] - , iflavour = zipPlain [BrBlue] + , ifreq = [("monster", 100), ("horror", 100), ("mobile monster", 100)] + , iflavour = zipFancy [BrBlue] , icount = 1 - , irarity = [(1, 3), (10, 5)] + , irarity = [(5, 5), (10, 5)] , iverbHit = "thud" , iweight = 80000 - , iaspects = [ AddMaxHP 5, AddMaxCalm 60, AddSpeed 30 - , AddSight 7 ] + , iaspects = [ AddMaxHP 5, AddMaxCalm 60, AddSpeed 30 ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "Hungers but never eats. Bites but never swallows. Burrows its own image through, but never carries anything back." -- rather weak: not about injective objects, but puny, concrete, injective functions --- where's the madness in that? , ikit = [ ("tooth", COrgan), ("speed gland 10", COrgan) - , ("lip", COrgan), ("lip", COrgan) ] + , ("lip", COrgan), ("vision 4", COrgan) + , ("sapient brain", COrgan) ] } -nose = ItemKind +nose = ItemKind -- depends solely on smell { isymbol = 'n' , iname = "point-free nose" - , ifreq = [("monster", 100), ("horror", 100)] - , iflavour = zipPlain [BrGreen] + , ifreq = [("monster", 100), ("horror", 100), ("mobile monster", 100)] + , iflavour = zipFancy [BrGreen] , icount = 1 - , irarity = [(1, 10), (3, 0), (4, 5), (10, 5)] -- ensure explorers at lvl 3 + , irarity = [(1, 5), (4, 2), (10, 5)] , iverbHit = "thud" , iweight = 80000 - , iaspects = [ AddMaxHP 20, AddMaxCalm 30, AddSpeed 18 - , AddSkills $ EM.fromList [(AbProject, -1), (AbApply, -1)] - , AddSmell 3 ] -- depends solely on smell + , iaspects = [ AddMaxHP 30, AddMaxCalm 30, AddSpeed 18 + , AddSkills $ EM.fromList [(AbProject, -1), (AbApply, -1)] ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "No mouth, yet it devours everything around, constantly sniffing itself inward; pure movement structure, no constant point to focus one's maddened gaze on." - , ikit = [("nose tip", COrgan), ("lip", COrgan)] + , ikit = [ ("nose tip", COrgan), ("lip", COrgan), ("nostril", COrgan) + , ("sapient brain", COrgan) ] } elbow = ItemKind { isymbol = 'e' , iname = "commutative elbow" - , ifreq = [("monster", 100), ("horror", 100)] - , iflavour = zipPlain [BrMagenta] + , ifreq = [("monster", 100), ("horror", 100), ("mobile monster", 100)] + , iflavour = zipFancy [BrMagenta] , icount = 1 - , irarity = [(6, 1), (10, 5)] + , irarity = [(7, 1), (10, 5)] , iverbHit = "thud" , iweight = 80000 - , iaspects = [ AddMaxHP 8, AddMaxCalm 90, AddSpeed 26 + , iaspects = [ AddMaxHP 8, AddMaxCalm 90, AddSpeed 21 , AddSkills - $ EM.fromList [(AbProject, 1), (AbApply, 1), (AbMelee, -1)] - , AddSight 15 ] + $ EM.fromList [(AbProject, 2), (AbApply, 1), (AbMelee, -1)] ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "An arm strung like a bow. A few edges, but none keen enough. A few points, but none piercing. Deadly objects zip out of the void." , ikit = [ ("speed gland 4", COrgan), ("armored skin", COrgan) + , ("vision 14", COrgan) , ("any arrow", CInv), ("any arrow", CInv) - , ("any arrow", CInv), ("any arrow", CInv) ] + , ("any arrow", CInv), ("any arrow", CInv) + , ("sapient brain", COrgan) ] } +torsor = ItemKind + { isymbol = 'T' + , iname = "The Forgetful Torsor" + , ifreq = [("monster", 100)] + , iflavour = zipFancy [BrCyan] + , icount = 1 + , irarity = [(9, 0), (10, 1000)] -- unique + , iverbHit = "thud" + , iweight = 80000 + , iaspects = [ Unique, AddMaxHP 200, AddMaxCalm 100, AddSpeed 10 + , AddSkills $ EM.fromList + [(AbProject, 2), (AbApply, 1), (AbTrigger, -1)] ] + -- can't switch levels, a miniboss + , ieffects = [] + , ifeature = [Durable, Identified] + , idesc = "A principal homogeneous manifold, that acts freely and with enormous force, but whose stabilizers are trivial, making it rather helpless without a support group." + , ikit = [ ("right torsion", COrgan), ("left torsion", COrgan) + , ("pupil", COrgan) + , ("gem", CInv), ("gem", CInv), ("gem", CInv), ("gem", CInv) + , ("sapient brain", COrgan) ] + } -- "ground x" --- for immovable monster that can only tele or prob travel --- forgetful -- pullback -- skeletal @@ -146,10 +176,59 @@ -- They need rather strong melee, because they don't use items. -- Unless/until they level up. -animalSkillMalus :: Skills -animalSkillMalus = - EM.fromList $ zip [AbDisplace, AbMoveItem, AbProject, AbApply] [-1, -1..] - +goldenJackal = ItemKind -- basically a much smaller and slower hyena + { isymbol = 'j' + , iname = "golden jackal" + , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100), ("scavenger", 50)] + , iflavour = zipPlain [BrYellow] + , icount = 1 + , irarity = [(1, 5)] + , iverbHit = "thud" + , iweight = 13000 + , iaspects = [ AddMaxHP 12, AddMaxCalm 60, AddSpeed 22 ] + , ieffects = [] + , ifeature = [Durable, Identified] + , idesc = "" + , ikit = [ ("small jaw", COrgan), ("eye 5", COrgan), ("nostril", COrgan) + , ("animal brain", COrgan) ] + } +griffonVulture = ItemKind + { isymbol = 'v' + , iname = "griffon vulture" + , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100), ("scavenger", 30)] + , iflavour = zipPlain [BrYellow] + , icount = 1 + , irarity = [(1, 5)] + , iverbHit = "thud" + , iweight = 13000 + , iaspects = [ AddMaxHP 12, AddMaxCalm 60, AddSpeed 20 + , AddSkills $ EM.singleton AbAlter (-1) ] + , ieffects = [] + , ifeature = [Durable, Identified] + , idesc = "" + , ikit = [ ("screeching beak", COrgan) -- in reality it grunts and hisses + , ("claw", COrgan), ("eye 6", COrgan) + , ("animal brain", COrgan) ] + } +skunk = ItemKind + { isymbol = 's' + , iname = "hog-nosed skunk" + , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] + , iflavour = zipPlain [White] + , icount = 1 + , irarity = [(1, 5), (10, 3)] + , iverbHit = "thud" + , iweight = 4000 + , iaspects = [ AddMaxHP 10, AddMaxCalm 30, AddSpeed 20 + , AddSkills $ EM.singleton AbAlter (-1) ] + , ieffects = [] + , ifeature = [Durable, Identified] + , idesc = "" + , ikit = [ ("scent gland", COrgan) + , ("small claw", COrgan), ("snout", COrgan) + , ("nostril", COrgan), ("eye 2", COrgan) + , ("animal brain", COrgan) ] + } armadillo = ItemKind { isymbol = 'a' , iname = "giant armadillo" @@ -160,13 +239,13 @@ , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 30, AddMaxCalm 30, AddSpeed 18 - , AddSkills $ EM.insert AbAlter (-1) animalSkillMalus - , AddSight 3 ] + , AddSkills $ EM.singleton AbAlter (-1) ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("claw", COrgan), ("snout", COrgan), ("armored skin", COrgan) - , ("nostril", COrgan) ] + , ("nostril", COrgan), ("eye 2", COrgan) + , ("animal brain", COrgan) ] } gilaMonster = ItemKind { isymbol = 'g' @@ -177,66 +256,66 @@ , irarity = [(2, 5), (10, 3)] , iverbHit = "thud" , iweight = 80000 - , iaspects = [ AddMaxHP 15, AddMaxCalm 60, AddSpeed 15 - , AddSkills $ EM.insert AbAlter (-1) animalSkillMalus - , AddSight 3 ] + , iaspects = [ AddMaxHP 12, AddMaxCalm 60, AddSpeed 15 + , AddSkills $ EM.singleton AbAlter (-1) ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("venom tooth", COrgan), ("small claw", COrgan) - , ("eye 4", COrgan), ("nostril", COrgan) ] + , ("eye 5", COrgan), ("nostril", COrgan) + , ("animal brain", COrgan) ] } rattlesnake = ItemKind - { isymbol = 'r' + { isymbol = 's' , iname = "rattlesnake" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] , iflavour = zipPlain [Brown] , icount = 1 - , irarity = [(3, 2), (10, 4)] + , irarity = [(3, 3), (10, 5)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 25, AddMaxCalm 60, AddSpeed 15 - , AddSkills $ EM.insert AbAlter (-1) animalSkillMalus - , AddSight 3 ] + , AddSkills $ EM.singleton AbAlter (-1) ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" , ikit = [ ("venom fang", COrgan) - , ("eye 4", COrgan), ("nostril", COrgan) ] + , ("eye 5", COrgan), ("nostril", COrgan) + , ("animal brain", COrgan) ] } -komodoDragon = ItemKind -- bad hearing +komodoDragon = ItemKind -- bad hearing; regeneration makes it very powerful { isymbol = 'k' , iname = "Komodo dragon" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] , iflavour = zipPlain [Blue] , icount = 1 - , irarity = [(5, 5), (10, 7)] + , irarity = [(7, 0), (10, 10)] , iverbHit = "thud" , iweight = 80000 - , iaspects = [ AddMaxHP 40, AddMaxCalm 60, AddSpeed 16 - , AddSkills animalSkillMalus, AddSight 3 ] + , iaspects = [ AddMaxHP 40, AddMaxCalm 60, AddSpeed 16 ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" - , ikit = [ ("large tail", COrgan), ("jaw", COrgan), ("small claw", COrgan) + , ikit = [ ("large tail", COrgan), ("jaw", COrgan), ("claw", COrgan) , ("speed gland 4", COrgan), ("armored skin", COrgan) - , ("eye 2", COrgan), ("nostril", COrgan) ] + , ("eye 2", COrgan), ("nostril", COrgan) + , ("animal brain", COrgan) ] } hyena = ItemKind { isymbol = 'h' , iname = "spotted hyena" - , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] - , iflavour = zipPlain [Red] + , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100), ("scavenger", 20)] + , iflavour = zipPlain [BrYellow] , icount = 1 - , irarity = [(4, 6), (10, 6)] + , irarity = [(4, 1), (10, 8)] , iverbHit = "thud" - , iweight = 80000 - , iaspects = [ AddMaxHP 20, AddMaxCalm 60, AddSpeed 30 - , AddSkills animalSkillMalus, AddSight 3 ] + , iweight = 60000 + , iaspects = [ AddMaxHP 20, AddMaxCalm 60, AddSpeed 30 ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" - , ikit = [("jaw", COrgan), ("eye 4", COrgan), ("nostril", COrgan)] + , ikit = [ ("jaw", COrgan), ("eye 5", COrgan), ("nostril", COrgan) + , ("animal brain", COrgan) ] } alligator = ItemKind { isymbol = 'a' @@ -244,73 +323,137 @@ , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] , iflavour = zipPlain [Blue] , icount = 1 - , irarity = [(10, 8)] + , irarity = [(6, 1), (10, 9)] , iverbHit = "thud" , iweight = 80000 - , iaspects = [ AddMaxHP 30, AddMaxCalm 60, AddSpeed 17 - , AddArmorMelee 30, AddArmorRanged 30 - , AddSkills animalSkillMalus, AddSight 3 ] + , iaspects = [ AddMaxHP 40, AddMaxCalm 60, AddSpeed 17 ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" - , ikit = [ ("large jaw", COrgan), ("large tail", COrgan), ("claw", COrgan) - , ("armored skin", COrgan), ("eye 4", COrgan) ] + , ikit = [ ("large jaw", COrgan), ("large tail", COrgan) + , ("small claw", COrgan) + , ("armored skin", COrgan), ("eye 5", COrgan) + , ("animal brain", COrgan) ] } +rhinoceros = ItemKind + { isymbol = 'R' + , iname = "The Maddened Rhinoceros" + , ifreq = [("animal", 100)] + , iflavour = zipPlain [Brown] + , icount = 1 + , irarity = [(2, 0), (3, 1000000), (4, 0)] -- unique + , iverbHit = "thud" + , iweight = 80000 + , iaspects = [ Unique, AddMaxHP 70, AddMaxCalm 60, AddSpeed 25 + , AddSkills $ EM.singleton AbTrigger (-1) ] + -- can't switch levels, a miniboss + , ieffects = [] + , ifeature = [Durable, Identified] + , idesc = "The last of its kind. Blind with rage. Charges at deadly speed." + , ikit = [ ("armored skin", COrgan), ("eye 2", COrgan) + , ("horn", COrgan), ("snout", COrgan) + , ("animal brain", COrgan) ] + } -- * Non-animal animals +beeSwarm = ItemKind + { isymbol = 'b' + , iname = "bee swarm" + , ifreq = [("animal", 100), ("horror", 100)] + , iflavour = zipPlain [Brown] + , icount = 1 + , irarity = [(1, 3), (10, 6)] + , iverbHit = "thud" + , iweight = 1000 + , iaspects = [ AddMaxHP 8, AddMaxCalm 60, AddSpeed 30 + , AddSkills $ EM.singleton AbAlter (-1) ] -- armor in sting + , ieffects = [] + , ifeature = [Durable, Identified] + , idesc = "" + , ikit = [ ("bee sting", COrgan), ("vision 4", COrgan) + , ("insect mortality", COrgan), ("animal brain", COrgan) ] + } hornetSwarm = ItemKind { isymbol = 'h' , iname = "hornet swarm" , ifreq = [("animal", 100), ("horror", 100), ("mobile animal", 100)] , iflavour = zipPlain [Magenta] , icount = 1 - , irarity = [(5, 1), (10, 5)] + , irarity = [(5, 1), (10, 10)] , iverbHit = "thud" , iweight = 1000 - , iaspects = [ AddMaxHP 5, AddMaxCalm 60, AddSpeed 30, AddSight 2 - , AddSkills $ EM.insert AbAlter (-1) animalSkillMalus - , AddArmorMelee 90, AddArmorRanged 90 ] + , iaspects = [ AddMaxHP 8, AddMaxCalm 60, AddSpeed 30 + , AddSkills $ EM.singleton AbAlter (-1) + , AddArmorMelee 80, AddArmorRanged 80 ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" - , ikit = [("sting", COrgan)] + , ikit = [ ("sting", COrgan), ("vision 4", COrgan) + , ("insect mortality", COrgan), ("animal brain", COrgan) ] } thornbush = ItemKind - { isymbol = 'b' + { isymbol = 't' , iname = "thornbush" , ifreq = [("animal", 100)] , iflavour = zipPlain [Brown] , icount = 1 - , irarity = [(3, 2), (10, 1)] + , irarity = [(1, 3), (10, 1)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 20, AddMaxCalm 999, AddSpeed 20 - , AddSkills - $ EM.fromDistinctAscList (zip [minBound..maxBound] [-1, -1..]) - `addSkills` EM.fromList (zip [AbWait, AbMelee] [1, 1..]) - , AddArmorMelee 50, AddArmorRanged 50 ] + , AddSkills $ EM.fromList (zip [AbWait, AbMelee] [1, 1..]) ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" - , ikit = [("thorn", COrgan)] + , ikit = [("thorn", COrgan), ("armored skin", COrgan)] } -geyser = ItemKind +geyserBoiling = ItemKind { isymbol = 'g' , iname = "geyser" - , ifreq = [("animal", 100)] - , iflavour = zipPlain [White] + , ifreq = [("animal", 50), ("immobile vents", 100)] + , iflavour = zipPlain [Blue] , icount = 1 , irarity = [(5, 2), (10, 1)] , iverbHit = "thud" , iweight = 80000 , iaspects = [ AddMaxHP 10, AddMaxCalm 999, AddSpeed 5 - , AddSkills - $ EM.fromDistinctAscList (zip [minBound..maxBound] [-1, -1..]) - `addSkills` EM.fromList (zip [AbWait, AbMelee] [1, 1..]) + , AddSkills $ EM.fromList (zip [AbWait, AbMelee] [1, 1..]) , AddArmorMelee 80, AddArmorRanged 80 ] , ieffects = [] , ifeature = [Durable, Identified] , idesc = "" - , ikit = [("vent", COrgan), ("fissure", COrgan)] + , ikit = [("boiling vent", COrgan), ("boiling fissure", COrgan)] + } +geyserArsenic = ItemKind + { isymbol = 'g' + , iname = "arsenic geyser" + , ifreq = [("animal", 50), ("immobile vents", 100)] + , iflavour = zipPlain [Cyan] + , icount = 1 + , irarity = [(5, 2), (10, 1)] + , iverbHit = "thud" + , iweight = 80000 + , iaspects = [ AddMaxHP 30, AddMaxCalm 999, AddSpeed 20, AddLight 3 + , AddSkills $ EM.fromList (zip [AbWait, AbMelee] [1, 1..]) ] + , ieffects = [] + , ifeature = [Durable, Identified] + , idesc = "" + , ikit = [("arsenic vent", COrgan), ("arsenic fissure", COrgan)] + } +geyserSulfur = ItemKind + { isymbol = 'g' + , iname = "sulfur geyser" + , ifreq = [("animal", 50), ("immobile vents", 300)] + , iflavour = zipPlain [BrYellow] -- exception, animal with bright color + , icount = 1 + , irarity = [(5, 4), (10, 2)] + , iverbHit = "thud" + , iweight = 80000 + , iaspects = [ AddMaxHP 30, AddMaxCalm 999, AddSpeed 20, AddLight 3 + , AddSkills $ EM.fromList (zip [AbWait, AbMelee] [1, 1..]) ] + , ieffects = [] + , ifeature = [Durable, Identified] + , idesc = "" + , ikit = [("sulfur vent", COrgan), ("sulfur fissure", COrgan)] } diff --git a/GameDefinition/Content/ItemKindBlast.hs b/GameDefinition/Content/ItemKindBlast.hs --- a/GameDefinition/Content/ItemKindBlast.hs +++ b/GameDefinition/Content/ItemKindBlast.hs @@ -10,9 +10,9 @@ blasts :: [ItemKind] blasts = - [burningOil2, burningOil3, burningOil4, explosionBlast2, explosionBlast10, explosionBlast20, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, fragrance, pheromone, mistHealing, mistHealing2, mistWounding, distortion, waste, glassPiece, smoke, boilingWater, glue, spark, mistAntiSlow, mistAntidote, mistStrength, mistWeakness, protectingBalm, redPaint, hasteSpray, slownessSpray, eyeDrop, smellyDroplet, whiskeySpray] + [burningOil2, burningOil3, burningOil4, explosionBlast2, explosionBlast10, explosionBlast20, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, fragrance, pheromone, mistCalming, odorDistressing, mistHealing, mistHealing2, mistWounding, distortion, waste, glassPiece, smoke, boilingWater, glue, spark, mistAntiSlow, mistAntidote, mistStrength, mistWeakness, protectingBalm, vulnerabilityBalm, hasteSpray, slownessSpray, eyeDrop, smellyDroplet, whiskeySpray] -burningOil2, burningOil3, burningOil4, explosionBlast2, explosionBlast10, explosionBlast20, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, fragrance, pheromone, mistHealing, mistHealing2, mistWounding, distortion, waste, glassPiece, smoke, boilingWater, glue, spark, mistAntiSlow, mistAntidote, mistStrength, mistWeakness, protectingBalm, redPaint, hasteSpray, slownessSpray, eyeDrop, smellyDroplet, whiskeySpray :: ItemKind +burningOil2, burningOil3, burningOil4, explosionBlast2, explosionBlast10, explosionBlast20, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, fragrance, pheromone, mistCalming, odorDistressing, mistHealing, mistHealing2, mistWounding, distortion, waste, glassPiece, smoke, boilingWater, glue, spark, mistAntiSlow, mistAntidote, mistStrength, mistWeakness, protectingBalm, vulnerabilityBalm, hasteSpray, slownessSpray, eyeDrop, smellyDroplet, whiskeySpray :: ItemKind -- * Parameterized immediate effect blasts @@ -22,13 +22,12 @@ , iname = "burning oil" , ifreq = [(toGroupName $ "burning oil" <+> tshow n, 1)] , iflavour = zipFancy [BrYellow] - , icount = intToDice (n * 4) + , icount = intToDice (n * 5) , irarity = [(1, 1)] , iverbHit = "burn" , iweight = 1 , iaspects = [AddLight 2] - , ieffects = [ Burn (n `div` 2) - , Paralyze (intToDice $ n `div` 2) ] -- tripping on oil + , ieffects = [Burn 1, Paralyze 1] -- tripping on oil , ifeature = [ toVelocity (min 100 $ n * 7) , Fragile, Identified ] , idesc = "Sticky oil, burning brightly." @@ -43,15 +42,15 @@ , iname = "blast" , ifreq = [(toGroupName $ "blast" <+> tshow n, 1)] , iflavour = zipPlain [BrRed] - , icount = 12 -- strong, but few, so not always hits target + , icount = 15 -- strong, but few, so not always hits target , irarity = [(1, 1)] , iverbHit = "tear apart" , iweight = 1 , iaspects = [AddLight $ intToDice n] - , ieffects = [RefillHP (- n `div` 2)] - ++ [DropBestWeapon | n > 2] + , ieffects = [Impress, RefillHP (- n `div` 2)] + ++ [PushActor (ThrowMod (100 * (n `div` 5)) 50)] ++ [DropItem COrgan "temporary conditions" True | n >= 10] - , ifeature = [Fragile, toLinger 10, Identified] + , ifeature = [Fragile, toLinger 20, Identified] , idesc = "" , ikit = [] } @@ -69,7 +68,9 @@ , iverbHit = "crack" , iweight = 1 , iaspects = [AddLight $ intToDice $ n `div` 2] - , ieffects = [ Burn 1 | n > 5 ] + , ieffects = [Impress] + ++ [ RefillCalm (-1) | n >= 5 ] + ++ [ DropBestWeapon | n >= 5] ++ [ OnSmash (Explode $ toGroupName $ "firecracker" <+> tshow (n - 1)) | n > 2 ] @@ -92,13 +93,15 @@ , iname = "fragrance" , ifreq = [("fragrance", 1)] , iflavour = zipFancy [Magenta] - , icount = 15 + , icount = 20 , irarity = [(1, 1)] , iverbHit = "engulf" , iweight = 1 , iaspects = [] , ieffects = [Impress] - , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps + -- Linger 10, because sometimes it takes 2 turns due to starting just + -- before actor turn's end (e.g., via a necklace). + , ifeature = [ ToThrow $ ThrowMod 28 10 -- 2 steps, one turn , Fragile, Identified ] , idesc = "" , ikit = [] @@ -108,23 +111,55 @@ , iname = "musky whiff" , ifreq = [("pheromone", 1)] , iflavour = zipFancy [BrMagenta] - , icount = 8 + , icount = 18 , irarity = [(1, 1)] , iverbHit = "tempt" , iweight = 1 , iaspects = [] - , ieffects = [Dominate] + , ieffects = [Impress, OverfillCalm (-20)] , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps , Fragile, Identified ] , idesc = "" , ikit = [] } +mistCalming = ItemKind + { isymbol = '\'' + , iname = "mist" + , ifreq = [("calming mist", 1)] + , iflavour = zipFancy [White] + , icount = 19 + , irarity = [(1, 1)] + , iverbHit = "sooth" + , iweight = 1 + , iaspects = [] + , ieffects = [RefillCalm 2] + , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps + , Fragile, Identified ] + , idesc = "" + , ikit = [] + } +odorDistressing = ItemKind + { isymbol = '\'' + , iname = "distressing whiff" + , ifreq = [("distressing odor", 1)] + , iflavour = zipFancy [BrRed] + , icount = 10 + , irarity = [(1, 1)] + , iverbHit = "distress" + , iweight = 1 + , iaspects = [] + , ieffects = [OverfillCalm (-20)] + , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps + , Fragile, Identified ] + , idesc = "" + , ikit = [] + } mistHealing = ItemKind { isymbol = '\'' , iname = "mist" , ifreq = [("healing mist", 1)] , iflavour = zipFancy [White] - , icount = 11 + , icount = 9 , irarity = [(1, 1)] , iverbHit = "revitalize" , iweight = 1 @@ -140,7 +175,7 @@ , iname = "mist" , ifreq = [("healing mist 2", 1)] , iflavour = zipFancy [White] - , icount = 12 + , icount = 8 , irarity = [(1, 1)] , iverbHit = "revitalize" , iweight = 1 @@ -156,7 +191,7 @@ , iname = "mist" , ifreq = [("wounding mist", 1)] , iflavour = zipFancy [White] - , icount = 13 + , icount = 7 , irarity = [(1, 1)] , iverbHit = "devitalize" , iweight = 1 @@ -172,12 +207,12 @@ , iname = "vortex" , ifreq = [("distortion", 1)] , iflavour = zipFancy [White] - , icount = 4 + , icount = 6 , irarity = [(1, 1)] , iverbHit = "engulf" , iweight = 1 , iaspects = [] - , ieffects = [Teleport $ 15 + d 10] + , ieffects = [Impress, Teleport $ 15 + d 10] , ifeature = [ toVelocity 7 -- the slowest that gets anywhere (1 step only) , Fragile, Identified ] , idesc = "" @@ -188,13 +223,13 @@ , iname = "waste" , ifreq = [("waste", 1)] , iflavour = zipPlain [Brown] - , icount = 10 + , icount = 18 , irarity = [(1, 1)] , iverbHit = "splosh" , iweight = 50 , iaspects = [] , ieffects = [RefillHP (-1)] - , ifeature = [ ToThrow $ ThrowMod 28 50 + , ifeature = [ ToThrow $ ThrowMod 28 10 -- 2 steps, one turn , Fragile, Identified ] , idesc = "" , ikit = [] @@ -204,7 +239,7 @@ , iname = "glass piece" , ifreq = [("glass piece", 1)] , iflavour = zipPlain [BrBlue] - , icount = 17 + , icount = 18 , irarity = [(1, 1)] , iverbHit = "cut" , iweight = 10 @@ -234,7 +269,7 @@ , iname = "boiling water" , ifreq = [("boiling water", 1)] , iflavour = zipPlain [BrWhite] - , icount = 10 + , icount = 21 , irarity = [(1, 1)] , iverbHit = "boil" , iweight = 5 @@ -249,7 +284,7 @@ , iname = "hoof glue" , ifreq = [("glue", 1)] , iflavour = zipPlain [BrYellow] - , icount = 14 + , icount = 20 , irarity = [(1, 1)] , iverbHit = "glue" , iweight = 20 @@ -264,7 +299,7 @@ , iname = "spark" , ifreq = [("spark", 1)] , iflavour = zipPlain [BrYellow] - , icount = 18 + , icount = 17 , irarity = [(1, 1)] , iverbHit = "burn" , iweight = 1 @@ -279,7 +314,7 @@ , iname = "mist" , ifreq = [("anti-slow mist", 1)] , iflavour = zipPlain [BrRed] - , icount = 11 + , icount = 7 , irarity = [(1, 1)] , iverbHit = "propel" , iweight = 1 @@ -295,7 +330,7 @@ , iname = "mist" , ifreq = [("antidote mist", 1)] , iflavour = zipPlain [BrBlue] - , icount = 11 + , icount = 8 , irarity = [(1, 1)] , iverbHit = "cure" , iweight = 1 @@ -314,7 +349,7 @@ , iname = "mist" , ifreq = [("strength mist", 1)] , iflavour = zipFancy [Red] - , icount = 11 + , icount = 6 , irarity = [(1, 1)] , iverbHit = "strengthen" , iweight = 1 @@ -330,7 +365,7 @@ , iname = "mist" , ifreq = [("weakness mist", 1)] , iflavour = zipFancy [Blue] - , icount = 12 + , icount = 5 , irarity = [(1, 1)] , iverbHit = "weaken" , iweight = 1 @@ -357,17 +392,17 @@ , idesc = "" , ikit = [] } -redPaint = ItemKind +vulnerabilityBalm = ItemKind { isymbol = '\'' - , iname = "red paint" - , ifreq = [("red paint", 1)] + , iname = "PhD defense question" + , ifreq = [("PhD defense question", 1)] , iflavour = zipPlain [BrRed] , icount = 14 , irarity = [(1, 1)] - , iverbHit = "paint" + , iverbHit = "nag" , iweight = 1 , iaspects = [] - , ieffects = [toOrganGameTurn "painted red" (3 + d 3)] + , ieffects = [toOrganGameTurn "defenseless" (3 + d 3)] , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps , Fragile, Identified ] , idesc = "" @@ -447,7 +482,7 @@ , iverbHit = "inebriate" , iweight = 1 , iaspects = [] - , ieffects = [toOrganActorTurn "drunk" (3 + d 3)] + , ieffects = [Impress, toOrganActorTurn "drunk" (3 + d 3)] , ifeature = [ toVelocity 13 -- the slowest that travels at least 2 steps , Fragile, Identified ] , idesc = "" diff --git a/GameDefinition/Content/ItemKindOrgan.hs b/GameDefinition/Content/ItemKindOrgan.hs --- a/GameDefinition/Content/ItemKindOrgan.hs +++ b/GameDefinition/Content/ItemKindOrgan.hs @@ -1,6 +1,9 @@ -- | Organ definitions. module Content.ItemKindOrgan ( organs ) where +import qualified Data.EnumMap.Strict as EM + +import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Flavour @@ -10,9 +13,9 @@ organs :: [ItemKind] organs = - [fist, foot, claw, smallClaw, snout, jaw, largeJaw, tooth, tentacle, lash, noseTip, lip, thorn, fissure, sting, venomTooth, venomFang, largeTail, pupil, armoredSkin, eye2, eye3, eye4, eye5, nostril, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, vent, bonusHP] + [fist, foot, claw, smallClaw, snout, smallJaw, jaw, largeJaw, tooth, horn, tentacle, lash, noseTip, lip, torsionRight, torsionLeft, thorn, boilingFissure, arsenicFissure, sulfurFissure, beeSting, sting, venomTooth, venomFang, screechingBeak, largeTail, pupil, armoredSkin, eye2, eye3, eye4, eye5, eye6, eye7, eye8, vision4, vision6, vision8, vision10, vision12, vision14, vision16, nostril, insectMortality, sapientBrain, animalBrain, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, scentGland, boilingVent, arsenicVent, sulfurVent, bonusHP] -fist, foot, claw, smallClaw, snout, jaw, largeJaw, tooth, tentacle, lash, noseTip, lip, thorn, fissure, sting, venomTooth, venomFang, largeTail, pupil, armoredSkin, eye2, eye3, eye4, eye5, nostril, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, vent, bonusHP :: ItemKind +fist, foot, claw, smallClaw, snout, smallJaw, jaw, largeJaw, tooth, horn, tentacle, lash, noseTip, lip, torsionRight, torsionLeft, thorn, boilingFissure, arsenicFissure, sulfurFissure, beeSting, sting, venomTooth, venomFang, screechingBeak, largeTail, pupil, armoredSkin, eye2, eye3, eye4, eye5, eye6, eye7, eye8, vision4, vision6, vision8, vision10, vision12, vision14, vision16, nostril, insectMortality, sapientBrain, animalBrain, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, scentGland, boilingVent, arsenicVent, sulfurVent, bonusHP :: ItemKind -- Weapons @@ -29,7 +32,7 @@ , iweight = 2000 , iaspects = [] , ieffects = [Hurt (4 * d 1)] - , ifeature = [Durable, EqpSlot EqpSlotWeapon "", Identified] + , ifeature = [Durable, Identified] , idesc = "" , ikit = [] } @@ -48,8 +51,9 @@ { iname = "claw" , ifreq = [("claw", 50)] , icount = 2 -- even if more, only the fore claws used for fighting - , iverbHit = "slash" - , ieffects = [Hurt (6 * d 1)] + , iverbHit = "hook" + , iaspects = [Timeout $ 4 + d 4] + , ieffects = [Hurt (2 * d 1), Recharging (toOrganGameTurn "slow 10" 2)] , idesc = "" } smallClaw = fist @@ -57,7 +61,7 @@ , ifreq = [("small claw", 50)] , icount = 2 , iverbHit = "slash" - , ieffects = [Hurt (3 * d 1)] + , ieffects = [Hurt (2 * d 1)] , idesc = "" } snout = fist @@ -67,12 +71,20 @@ , ieffects = [Hurt (2 * d 1)] , idesc = "" } +smallJaw = fist + { iname = "small jaw" + , ifreq = [("small jaw", 20)] + , icount = 1 + , iverbHit = "rip" + , ieffects = [Hurt (3 * d 1)] + , idesc = "" + } jaw = fist { iname = "jaw" , ifreq = [("jaw", 20)] , icount = 1 , iverbHit = "rip" - , ieffects = [Hurt (4 * d 1)] + , ieffects = [Hurt (5 * d 1)] , idesc = "" } largeJaw = fist @@ -91,6 +103,14 @@ , ieffects = [Hurt (2 * d 1)] , idesc = "" } +horn = fist + { iname = "horn" + , ifreq = [("horn", 20)] + , icount = 2 + , iverbHit = "impale" + , ieffects = [Hurt (8 * d 1)] + , idesc = "" + } -- * Monster weapon organs @@ -107,7 +127,8 @@ , ifreq = [("lash", 100)] , icount = 1 , iverbHit = "lash" - , ieffects = [Hurt (3 * d 1), DropItem COrgan "far-sighted" True] + , iaspects = [Timeout $ 3 + d 3] + , ieffects = [Hurt (3 * d 1), Recharging $ DropItem COrgan "far-sighted" True] , idesc = "" } noseTip = fist @@ -123,37 +144,82 @@ , ifreq = [("lip", 10)] , icount = 2 , iverbHit = "lap" - , ieffects = [Hurt (2 * d 1), DropItem COrgan "keen-smelling" True] -- TODO: decrease Hurt, but use + , iaspects = [Timeout $ 3 + d 3] + , ieffects = [ Hurt (1 * d 1) + , Recharging $ DropItem COrgan "keen-smelling" True ] , idesc = "" } +torsionRight = fist + { iname = "right torsion" + , ifreq = [("right torsion", 100)] + , icount = 1 + , iverbHit = "twist" + , iaspects = [Timeout $ 5 + d 5] + , ieffects = [ Hurt (17 * d 1) + , Recharging (toOrganGameTurn "slow 10" (3 + d 3)) ] + , idesc = "" + } +torsionLeft = fist + { iname = "left torsion" + , ifreq = [("left torsion", 100)] + , icount = 1 + , iverbHit = "twist" + , iaspects = [Timeout $ 5 + d 5] + , ieffects = [ Hurt (17 * d 1) + , Recharging (toOrganGameTurn "weakened" (3 + d 3)) ] + , idesc = "" + } -- * Special weapon organs thorn = fist { iname = "thorn" , ifreq = [("thorn", 100)] - , icount = 7 + , icount = 2 + d 3 , iverbHit = "impale" , ieffects = [Hurt (2 * d 1)] - , ifeature = [EqpSlot EqpSlotWeapon "", Identified] -- not Durable + , ifeature = [Identified] -- not Durable , idesc = "" } -fissure = fist +boilingFissure = fist { iname = "fissure" - , ifreq = [("fissure", 100)] - , icount = 2 + , ifreq = [("boiling fissure", 100)] + , icount = 5 + d 5 , iverbHit = "hiss at" - , ieffects = [Burn 1] + , ieffects = [Burn $ 1 * d 1] + , ifeature = [Identified] -- not Durable , idesc = "" } +arsenicFissure = boilingFissure + { iname = "fissure" + , ifreq = [("arsenic fissure", 100)] + , icount = 2 + d 2 + , ieffects = [Burn $ 1 * d 1, toOrganGameTurn "weakened" (2 + d 2)] + } +sulfurFissure = boilingFissure + { iname = "fissure" + , ifreq = [("sulfur fissure", 100)] + , icount = 2 + d 2 + , ieffects = [Burn $ 1 * d 1, RefillHP 6] + } +beeSting = fist + { iname = "bee sting" + , ifreq = [("bee sting", 100)] + , icount = 1 + , iverbHit = "sting" + , iaspects = [AddArmorMelee 90, AddArmorRanged 90] + , ieffects = [Burn $ 2 * d 1, Paralyze 10, RefillHP 5] + , ifeature = [Identified] -- not Durable + , idesc = "Painful, but beneficial." + } sting = fist { iname = "sting" , ifreq = [("sting", 100)] , icount = 1 , iverbHit = "sting" , iaspects = [Timeout $ 1 + d 5] - , ieffects = [Burn 1, Recharging (Paralyze 3)] - , idesc = "" + , ieffects = [Burn $ 1 * d 1, Recharging (Paralyze 3)] + , idesc = "Painful, debilitating and harmful." } venomTooth = fist { iname = "venom tooth" @@ -161,7 +227,7 @@ , icount = 2 , iverbHit = "bite" , iaspects = [Timeout $ 5 + d 3] - , ieffects = [ Hurt (3 * d 1) + , ieffects = [ Hurt (2 * d 1) , Recharging (toOrganGameTurn "slow 10" (3 + d 3)) ] , idesc = "" } @@ -173,10 +239,20 @@ , icount = 2 , iverbHit = "bite" , iaspects = [Timeout $ 7 + d 5] - , ieffects = [ Hurt (3 * d 1) + , ieffects = [ Hurt (2 * d 1) , Recharging (toOrganNone "poisoned") ] , idesc = "" } +screechingBeak = armoredSkin + { iname = "screeching beak" + , ifreq = [("screeching beak", 100)] + , icount = 1 + , iverbHit = "peck" + , iaspects = [Timeout $ 5 + d 5] + , ieffects = [ Recharging (Summon [("scavenger", 1)] $ 1 + dl 2) + , Hurt (2 * d 1) ] + , idesc = "" + } largeTail = fist { iname = "large tail" , ifreq = [("large tail", 50)] @@ -191,8 +267,11 @@ , ifreq = [("pupil", 100)] , icount = 1 , iverbHit = "gaze at" - , iaspects = [AddSight 7, Timeout $ 5 + d 5] - , ieffects = [Hurt (3 * d 1), Recharging (DropItem COrgan "temporary conditions" True)] -- TODO: decrease Hurt, but use + , iaspects = [AddSight 10, Timeout $ 5 + d 5] + , ieffects = [ Hurt (1 * d 1) + , Recharging (DropItem COrgan "temporary conditions" True) + , Recharging $ RefillHP (-2) + ] , idesc = "" } @@ -231,17 +310,63 @@ eye3 = eye 3 eye4 = eye 4 eye5 = eye 5 +eye6 = eye 6 +eye7 = eye 7 +eye8 = eye 8 +vision :: Int -> ItemKind +vision n = armoredSkin + { iname = "vision" + , ifreq = [(toGroupName $ "vision" <+> tshow n, 100)] + , icount = 1 + , iverbHit = "visualize" + , iaspects = [AddSight (intToDice n)] + , idesc = "" + } +vision4 = vision 4 +vision6 = vision 6 +vision8 = vision 8 +vision10 = vision 10 +vision12 = vision 12 +vision14 = vision 14 +vision16 = vision 16 nostril = armoredSkin { iname = "nostril" , ifreq = [("nostril", 100)] , icount = 2 , iverbHit = "snuff" - , iaspects = [AddSmell 1] + , iaspects = [AddSmell 2] , idesc = "" } -- * Assorted +insectMortality = fist + { iname = "insect mortality" + , ifreq = [("insect mortality", 100)] + , icount = 1 + , iverbHit = "age" + , iaspects = [Periodic, Timeout $ 40 + d 10] + , ieffects = [Recharging (RefillHP (-1))] + , idesc = "" + } +sapientBrain = armoredSkin + { iname = "sapient brain" + , ifreq = [("sapient brain", 100)] + , icount = 1 + , iverbHit = "outbrain" + , iaspects = [AddSkills unitSkills] + , idesc = "" + } +animalBrain = armoredSkin + { iname = "animal brain" + , ifreq = [("animal brain", 100)] + , icount = 1 + , iverbHit = "blank" + , iaspects = [let absNo = [AbDisplace, AbMoveItem, AbProject, AbApply] + sk = EM.fromList $ zip absNo [-1, -1..] + in AddSkills $ addSkills unitSkills sk] + , idesc = "" + } speedGland :: Int -> ItemKind speedGland n = armoredSkin { iname = "speed gland" @@ -259,14 +384,41 @@ speedGland6 = speedGland 6 speedGland8 = speedGland 8 speedGland10 = speedGland 10 -vent = armoredSkin +scentGland = armoredSkin -- TODO: cone attack, 3m away, project? apply? + { iname = "scent gland" + , ifreq = [("scent gland", 100)] + , icount = 2 + , iverbHit = "spray at" + , iaspects = [Periodic, Timeout $ 10 + d 2 |*| 5 ] + , ieffects = [ Recharging (Explode "distressing odor") + , Recharging ApplyPerfume ] + , idesc = "" + } +boilingVent = armoredSkin { iname = "vent" - , ifreq = [("vent", 100)] + , ifreq = [("boiling vent", 100)] + , iflavour = zipPlain [Blue] , icount = 1 , iverbHit = "menace" - , iaspects = [Periodic, Timeout $ (2 + d 4) |*| 5] + , iaspects = [Periodic, Timeout $ 2 + d 2 |*| 5] , ieffects = [Recharging (Explode "boiling water")] , idesc = "" + } +arsenicVent = boilingVent + { iname = "vent" + , ifreq = [("arsenic vent", 100)] + , iflavour = zipPlain [Cyan] + , iaspects = [Periodic, Timeout $ 2 + d 2 |*| 5] + , ieffects = [ Recharging (Explode "weakness mist") + , Recharging (RefillHP (-1)) ] + } +sulfurVent = boilingVent + { iname = "vent" + , ifreq = [("sulfur vent", 100)] + , iflavour = zipPlain [BrYellow] + , iaspects = [Periodic, Timeout $ 2 + d 2 |*| 5] + , ieffects = [ Recharging (Explode "strength mist") + , Recharging (RefillHP (-1)) ] } bonusHP = armoredSkin { iname = "bonus HP" diff --git a/GameDefinition/Content/ItemKindTemporary.hs b/GameDefinition/Content/ItemKindTemporary.hs --- a/GameDefinition/Content/ItemKindTemporary.hs +++ b/GameDefinition/Content/ItemKindTemporary.hs @@ -12,22 +12,22 @@ temporaries :: [ItemKind] temporaries = - [tmpStrengthened, tmpWeakened, tmpProtected, tmpPaintedRed, tmpFast20, tmpSlow10, tmpFarSighted, tmpKeenSmelling, tmpDrunk, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResitant] + [tmpStrengthened, tmpWeakened, tmpProtected, tmpVulnerable, tmpFast20, tmpSlow10, tmpFarSighted, tmpKeenSmelling, tmpDrunk, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResistant] -tmpStrengthened, tmpWeakened, tmpProtected, tmpPaintedRed, tmpFast20, tmpSlow10, tmpFarSighted, tmpKeenSmelling, tmpDrunk, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResitant :: ItemKind +tmpStrengthened, tmpWeakened, tmpProtected, tmpVulnerable, tmpFast20, tmpSlow10, tmpFarSighted, tmpKeenSmelling, tmpDrunk, tmpRegenerating, tmpPoisoned, tmpSlow10Resistant, tmpPoisonResistant :: ItemKind -- The @name@ is be used in item description, so it should be an adjective -- describing the temporary set of aspects. tmpAs :: Text -> [Aspect Dice] -> ItemKind tmpAs name aspects = ItemKind - { isymbol = '.' + { isymbol = '+' , iname = name , ifreq = [(toGroupName name, 1), ("temporary conditions", 1)] , iflavour = zipPlain [BrWhite] , icount = 1 , irarity = [(1, 1)] , iverbHit = "affect" - , iweight = 1 + , iweight = 0 , iaspects = [Periodic, Timeout 0] -- activates and vanishes soon, -- depending on initial timer setting ++ aspects @@ -42,12 +42,12 @@ tmpWeakened = tmpAs "weakened" [AddHurtMelee (-20)] tmpProtected = tmpAs "protected" [ AddArmorMelee 30 , AddArmorRanged 30 ] -tmpPaintedRed = tmpAs "painted red" [ AddArmorMelee (-30) +tmpVulnerable = tmpAs "defenseless" [ AddArmorMelee (-30) , AddArmorRanged (-30) ] tmpFast20 = tmpAs "fast 20" [AddSpeed 20] tmpSlow10 = tmpAs "slow 10" [AddSpeed (-10)] tmpFarSighted = tmpAs "far-sighted" [AddSight 5] -tmpKeenSmelling = tmpAs "keen-smelling" [AddSmell 1] +tmpKeenSmelling = tmpAs "keen-smelling" [AddSmell 2] tmpDrunk = tmpAs "drunk" [ AddHurtMelee 30 -- fury , AddArmorMelee (-20) , AddArmorRanged (-20) @@ -56,20 +56,20 @@ tmpRegenerating = let tmp = tmpAs "regenerating" [] in tmp { icount = 7 + d 5 - , ieffects = [Recharging (RefillHP 1)] ++ ieffects tmp + , ieffects = Recharging (RefillHP 1) : ieffects tmp } tmpPoisoned = let tmp = tmpAs "poisoned" [] in tmp { icount = 7 + d 5 - , ieffects = [Recharging (RefillHP (-1))] ++ ieffects tmp + , ieffects = Recharging (RefillHP (-1)) : ieffects tmp } tmpSlow10Resistant = let tmp = tmpAs "slow resistant" [] in tmp { icount = 7 + d 5 - , ieffects = [Recharging (DropItem COrgan "slow 10" True)] ++ ieffects tmp + , ieffects = Recharging (DropItem COrgan "slow 10" True) : ieffects tmp } -tmpPoisonResitant = +tmpPoisonResistant = let tmp = tmpAs "poison resistant" [] in tmp { icount = 7 + d 5 - , ieffects = [Recharging (DropItem COrgan "poisoned" True)] ++ ieffects tmp + , ieffects = Recharging (DropItem COrgan "poisoned" True) : ieffects tmp } diff --git a/GameDefinition/Content/ModeKind.hs b/GameDefinition/Content/ModeKind.hs --- a/GameDefinition/Content/ModeKind.hs +++ b/GameDefinition/Content/ModeKind.hs @@ -5,6 +5,7 @@ import Content.ModeKindPlayer import Game.LambdaHack.Common.ContentDef +import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ModeKind @@ -16,12 +17,12 @@ , validateSingle = validateSingleModeKind , validateAll = validateAllModeKind , content = - [campaign, duel, skirmish, ambush, battle, safari, pvp, coop, defense, screensaver] + [campaign, duel, skirmish, ambush, battle, battleSurvival, safari, safariSurvival, pvp, coop, defense, screensaver, boardgame] } -campaign, duel, skirmish, ambush, battle, safari, pvp, coop, defense, screensaver :: ModeKind +campaign, duel, skirmish, ambush, battle, battleSurvival, safari, safariSurvival, pvp, coop, defense, screensaver, boardgame :: ModeKind campaign = ModeKind - { msymbol = 'a' + { msymbol = 'n' , mname = "campaign" , mfreq = [("campaign", 1)] , mroster = rosterCampaign @@ -65,6 +66,15 @@ , mdesc = "Odds are stacked against those that unleash the horrors of abstraction." } +battleSurvival = ModeKind + { msymbol = 'i' + , mname = "battle survival" + , mfreq = [("battle survival", 1)] + , mroster = rosterBattleSurvival + , mcaves = cavesBattle + , mdesc = "Odds are stacked for those that breathe mathematics." + } + safari = ModeKind { msymbol = 'f' , mname = "safari" @@ -74,6 +84,15 @@ , 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)." } +safariSurvival = ModeKind + { msymbol = 'n' + , mname = "safari survival" + , 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." + } + pvp = ModeKind { msymbol = 'v' , mname = "PvP" @@ -106,14 +125,24 @@ , mfreq = [("screensaver", 1), ("starting", 1)] , mroster = rosterSafari { rosterList = (head (rosterList rosterSafari)) - {fleaderMode = LeaderAI $ AutoLeader False False } + -- changing leader by client needed, because of TFollow + {fleaderMode = LeaderAI $ AutoLeader True False} : tail (rosterList rosterSafari) } } +boardgame = ModeKind + { msymbol = 'g' + , mname = "boardgame" + , mfreq = [("boardgame", 1)] + , mroster = rosterBoardgame + , mcaves = cavesBoardgame + , mdesc = "Small room, no exits. Who will prevail?" + } -rosterCampaign, rosterDuel, rosterSkirmish, rosterAmbush, rosterBattle, rosterSafari, rosterPvP, rosterCoop, rosterDefense :: Roster +rosterCampaign, rosterDuel, rosterSkirmish, rosterAmbush, rosterBattle, rosterBattleSurvival, rosterSafari, rosterSafariSurvival, rosterPvP, rosterCoop, rosterDefense, rosterBoardgame:: Roster + rosterCampaign = Roster { rosterList = [ playerHero , playerMonster @@ -124,9 +153,11 @@ rosterDuel = Roster { rosterList = [ playerHero { fname = "White Recursive" + , fhiCondPoly = hiDweller , fentryLevel = -3 , finitialActors = 1 } , playerAntiHero { fname = "Red Iterative" + , fhiCondPoly = hiDweller , fentryLevel = -3 , finitialActors = 1 } , playerHorror ] @@ -137,8 +168,10 @@ rosterSkirmish = rosterDuel { rosterList = [ playerHero { fname = "White Haskell" + , fhiCondPoly = hiDweller , fentryLevel = -3 } , playerAntiHero { fname = "Purple Agda" + , fhiCondPoly = hiDweller , fentryLevel = -3 } , playerHorror ] , rosterEnemy = [ ("White Haskell", "Purple Agda") @@ -146,51 +179,85 @@ , ("Purple Agda", "Horror Den") ] } rosterAmbush = rosterDuel - { rosterList = [ playerHero { fname = "Yellow Idris" - , fentryLevel = -5 } - , playerAntiHero { fname = "Blue Epigram" - , fentryLevel = -5 } + { rosterList = [ playerSniper { fname = "Yellow Idris" + , fhiCondPoly = hiDweller + , fentryLevel = -5 + , finitialActors = 4 } + , playerAntiSniper { fname = "Blue Epigram" + , fhiCondPoly = hiDweller + , fentryLevel = -5 + , finitialActors = 4 } , playerHorror {fentryLevel = -5} ] , rosterEnemy = [ ("Yellow Idris", "Blue Epigram") , ("Yellow Idris", "Horror Den") , ("Blue Epigram", "Horror Den") ] } rosterBattle = Roster - { rosterList = [ playerSoldier { finitialActors = 5 - , fentryLevel = -5 } - , playerMobileMonster { finitialActors = 35 - , fentryLevel = -5 + { rosterList = [ playerSoldier { fhiCondPoly = hiDweller + , fentryLevel = -5 + , finitialActors = 5 } + , playerMobileMonster { fentryLevel = -5 + , finitialActors = 35 , fneverEmpty = True } - , playerMobileAnimal { finitialActors = 30 - , fentryLevel = -5 + , playerMobileAnimal { fentryLevel = -5 + , finitialActors = 30 , fneverEmpty = True } ] , rosterEnemy = [ ("Armed Adventurer Party", "Monster Hive") , ("Armed Adventurer Party", "Animal Kingdom") ] , rosterAlly = [("Monster Hive", "Animal Kingdom")] } -rosterSafari = Roster - { rosterList = [ playerAntiMonster { fname = "Monster Tourist Office" - , fcanEscape = True - , fneverEmpty = True - -- Follow-the-guide, as tourists do. - , ftactic = TFollow - , fentryLevel = -4 - , finitialActors = 15 - , fleaderMode = - -- no spawning and TFollow - LeaderUI $ AutoLeader False False } - , playerCivilian { fname = "Hunam Convict Pack" - , fentryLevel = -4 } - , playerMobileAnimal { fname = - "Animal Magnificent Specimen Variety" - , fneverEmpty = True - , fentryLevel = -7 - , finitialActors = 10 } - , playerMobileAnimal { fname = - "Animal Exquisite Herds and Packs" +rosterBattleSurvival = rosterBattle + { rosterList = [ playerSoldier { fhiCondPoly = hiDweller + , fentryLevel = -5 + , finitialActors = 5 + , fleaderMode = + LeaderAI $ AutoLeader True False + , fhasUI = False } + , playerMobileMonster { fentryLevel = -5 + , finitialActors = 35 + , fneverEmpty = True } + , playerMobileAnimal { fentryLevel = -5 + , finitialActors = 30 , fneverEmpty = True - , fentryLevel = -10 - , finitialActors = 30 } ] + , fhasUI = True } ] } + +playerMonsterTourist, playerHunamConvict, playerAnimalMagnificent, playerAnimalExquisite :: Player Dice + +playerMonsterTourist = + playerAntiMonster { fname = "Monster Tourist Office" + , fcanEscape = True + , fneverEmpty = True -- no spawning + -- Follow-the-guide, as tourists do. + , ftactic = TFollow + , fentryLevel = -4 + , finitialActors = 15 + , fleaderMode = + LeaderUI $ AutoLeader False False } + +playerHunamConvict = + playerCivilian { fname = "Hunam Convict Pack" + , fentryLevel = -4 } + +playerAnimalMagnificent = + playerMobileAnimal { fname = "Animal Magnificent Specimen Variety" + , fneverEmpty = True + , fentryLevel = -7 + , finitialActors = 10 + , fleaderMode = -- move away from stairs + LeaderAI $ AutoLeader True False } + +playerAnimalExquisite = + playerMobileAnimal { fname = "Animal Exquisite Herds and Packs" + , fneverEmpty = True + , fentryLevel = -10 + , finitialActors = 30 } + +rosterSafari = Roster + { rosterList = [ playerMonsterTourist + , playerHunamConvict + , playerAnimalMagnificent + , playerAnimalExquisite + ] , rosterEnemy = [ ("Monster Tourist Office", "Hunam Convict Pack") , ("Monster Tourist Office", "Animal Magnificent Specimen Variety") @@ -199,10 +266,23 @@ , rosterAlly = [( "Animal Magnificent Specimen Variety" , "Animal Exquisite Herds and Packs" )] } +rosterSafariSurvival = rosterSafari + { rosterList = [ playerMonsterTourist + { fleaderMode = LeaderAI $ AutoLeader True False + , fhasUI = False } + , playerHunamConvict + , playerAnimalMagnificent + { fleaderMode = LeaderUI $ AutoLeader False False + , fhasUI = True } + , playerAnimalExquisite + ] } + rosterPvP = Roster { rosterList = [ playerHero { fname = "Red" + , fhiCondPoly = hiDweller , fentryLevel = -3 } , playerHero { fname = "Blue" + , fhiCondPoly = hiDweller , fentryLevel = -3 } , playerHorror ] , rosterEnemy = [ ("Red", "Blue") @@ -230,18 +310,32 @@ , ("Green", "Leaderless Monster Hive") ] } rosterDefense = Roster - { rosterList = [ playerAntiMonster - , playerAntiHero {fname = "Yellow"} + { rosterList = [ playerAntiHero + , playerAntiMonster , playerAnimal ] - , rosterEnemy = [ ("Yellow", "Monster Hive") - , ("Yellow", "Animal Kingdom") ] + , rosterEnemy = [ ("Adventurer Party", "Monster Hive") + , ("Adventurer Party", "Animal Kingdom") ] , rosterAlly = [("Monster Hive", "Animal Kingdom")] } +rosterBoardgame = Roster + { rosterList = [ playerHero { fname = "Blue" + , fhiCondPoly = hiDweller + , fentryLevel = -3 + , finitialActors = 6 } + , playerAntiHero { fname = "Red" + , fhiCondPoly = hiDweller + , fentryLevel = -3 + , finitialActors = 6 } + , playerHorror ] + , rosterEnemy = [ ("Blue", "Red") + , ("Blue", "Horror Den") + , ("Red", "Horror Den") ] + , rosterAlly = [] } -cavesCampaign, cavesSkirmish, cavesAmbush, cavesBattle, cavesSafari :: Caves +cavesCampaign, cavesSkirmish, cavesAmbush, cavesBattle, cavesSafari, cavesBoardgame :: Caves cavesCampaign = IM.fromList - $ [ (-1, ("caveRogue", Just True)) + $ [ (-1, ("shallow random 1", Just True)) , (-2, ("caveRogue", Nothing)) , (-3, ("caveEmpty", Nothing)) ] ++ zip [-4, -5..(-9)] (repeat ("campaign random", Nothing)) @@ -256,3 +350,5 @@ cavesSafari = IM.fromList [ (-4, ("caveSafari1", Nothing)) , (-7, ("caveSafari2", Nothing)) , (-10, ("caveSafari3", Just False)) ] + +cavesBoardgame = IM.fromList [(-3, ("caveBoardgame", Nothing))] diff --git a/GameDefinition/Content/ModeKindPlayer.hs b/GameDefinition/Content/ModeKindPlayer.hs --- a/GameDefinition/Content/ModeKindPlayer.hs +++ b/GameDefinition/Content/ModeKindPlayer.hs @@ -1,18 +1,22 @@ -- | Basic players definitions. module Content.ModeKindPlayer - ( playerHero, playerSoldier, playerAntiHero, playerCivilian, playerMonster - , playerMobileMonster, playerAntiMonster, playerAnimal, playerMobileAnimal + ( playerHero, playerSoldier, playerSniper + , playerAntiHero, playerAntiSniper, playerCivilian + , playerMonster, playerMobileMonster, playerAntiMonster + , playerAnimal, playerMobileAnimal , playerHorror + , hiHero, hiDweller ) where import qualified Data.EnumMap.Strict as EM +import Data.List import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ModeKind -playerHero, playerSoldier, playerAntiHero, playerCivilian, playerMonster, playerMobileMonster, playerAntiMonster, playerAnimal, playerMobileAnimal, playerHorror :: Player Dice +playerHero, playerSoldier, playerSniper, playerAntiHero, playerAntiSniper, playerCivilian, playerMonster, playerMobileMonster, playerAntiMonster, playerAnimal, playerMobileAnimal, playerHorror :: Player Dice playerHero = Player { fname = "Adventurer Party" @@ -20,6 +24,7 @@ , fskillsOther = meleeAdjacent , fcanEscape = True , fneverEmpty = True + , fhiCondPoly = hiHero , fhasNumbers = True , fhasGender = True , ftactic = TExplore @@ -34,17 +39,28 @@ , fgroup = "soldier" } +playerSniper = playerHero + { fname = "Sniper Adventurer Party" + , fgroup = "sniper" + } + playerAntiHero = playerHero { fleaderMode = LeaderAI $ AutoLeader True False , fhasUI = False } +playerAntiSniper = playerSniper + { fleaderMode = LeaderAI $ AutoLeader True False + , fhasUI = False + } + playerCivilian = Player { fname = "Civilian Crowd" , fgroup = "civilian" - , fskillsOther = unitSkills -- not coordinated by any leadership + , fskillsOther = zeroSkills -- not coordinated by any leadership , fcanEscape = False , fneverEmpty = True + , fhiCondPoly = hiDweller , fhasNumbers = False , fhasGender = True , ftactic = TPatrol @@ -57,15 +73,19 @@ playerMonster = Player { fname = "Monster Hive" , fgroup = "monster" - , fskillsOther = unitSkills + , fskillsOther = zeroSkills , fcanEscape = False , fneverEmpty = False + , fhiCondPoly = hiDweller , fhasNumbers = False , fhasGender = False , ftactic = TExplore - , fentryLevel = -3 - , finitialActors = 1 -- an explorer, not a nose, ensured via irarity - , fleaderMode = LeaderAI $ AutoLeader True True + , fentryLevel = -4 + , finitialActors = 4 -- one of these most probably not nose, so will explore + , fleaderMode = + -- No point changing leader on level, since all move and they + -- don't follow the leader. + LeaderAI $ AutoLeader True True , fhasUI = False } @@ -79,13 +99,14 @@ playerAnimal = Player { fname = "Animal Kingdom" , fgroup = "animal" - , fskillsOther = unitSkills + , fskillsOther = zeroSkills , fcanEscape = False , fneverEmpty = False + , fhiCondPoly = hiDweller , fhasNumbers = False , fhasGender = False , ftactic = TRoam -- can't pick up, so no point exploring - , fentryLevel = -1 -- fun from the start; don't cumulate with monsters + , fentryLevel = -1 -- fun from the start to avoid empty initial level , finitialActors = 1 + d 2 , fleaderMode = LeaderNull , fhasUI = False @@ -103,9 +124,10 @@ playerHorror = Player { fname = "Horror Den" , fgroup = "horror" - , fskillsOther = unitSkills + , fskillsOther = zeroSkills , fcanEscape = False , fneverEmpty = False + , fhiCondPoly = [] , fhasNumbers = False , fhasGender = False , ftactic = TPatrol -- disoriented @@ -115,14 +137,36 @@ , fhasUI = False } -minusHundred, meleeAdjacent, _meleeAndRanged :: Skills +victoryOutcomes :: [Outcome] +victoryOutcomes = [Conquer, Escape] --- To make sure weak items can't override move-only-leader, etc. -minusHundred = EM.fromList $ zip [minBound..maxBound] [-100, -100..] +hiHero, hiDweller :: HiCondPoly -meleeAdjacent = addSkills minusHundred - $ EM.fromList $ zip [AbWait, AbMelee] [101, 101..] +-- Heroes rejoice in loot. +hiHero = [ ( [(HiLoot, 1)] + , [minBound..maxBound] ) + , ( [(HiConst, 1000), (HiLoss, -100)] + , victoryOutcomes ) + ] +-- Spawners or skirmishers get no points from loot, but try to kill +-- all opponents fast or at least hold up for long. +hiDweller = [ ( [(HiConst, 1000)] -- no loot + , victoryOutcomes ) + , ( [(HiConst, 1000), (HiLoss, -10)] + , victoryOutcomes ) + , ( [(HiBlitz, -100)] + , victoryOutcomes ) + , ( [(HiSurvival, 100)] + , [minBound..maxBound] \\ victoryOutcomes ) + ] + +minusTen, meleeAdjacent, _meleeAndRanged :: Skills + +-- To make sure only a lot of weak items can override move-only-leader, etc. +minusTen = EM.fromList $ zip [minBound..maxBound] [-10, -10..] + +meleeAdjacent = EM.delete AbWait $ EM.delete AbMelee minusTen + -- Melee and reaction fire. -_meleeAndRanged = addSkills minusHundred - $ EM.fromList $ zip [AbWait, AbMelee, AbProject] [101, 101..] +_meleeAndRanged = EM.delete AbProject $ meleeAdjacent diff --git a/GameDefinition/Content/PlaceKind.hs b/GameDefinition/Content/PlaceKind.hs --- a/GameDefinition/Content/PlaceKind.hs +++ b/GameDefinition/Content/PlaceKind.hs @@ -12,9 +12,9 @@ , validateSingle = validateSinglePlaceKind , validateAll = validateAllPlaceKind , content = - [rect, ruin, collapsed, collapsed2, collapsed3, collapsed4, pillar, pillar2, pillar3, pillar4, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, treeShade2, treeShade3] + [rect, ruin, collapsed, collapsed2, collapsed3, collapsed4, pillar, pillar2, pillar3, pillar4, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, treeShade2, treeShade3, boardgame] } -rect, ruin, collapsed, collapsed2, collapsed3, collapsed4, pillar, pillar2, pillar3, pillar4, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, treeShade2, treeShade3 :: PlaceKind +rect, ruin, collapsed, collapsed2, collapsed3, collapsed4, pillar, pillar2, pillar3, pillar4, colonnade, colonnade2, colonnade3, colonnade4, colonnade5, colonnade6, lampPost, lampPost2, lampPost3, lampPost4, treeShade, treeShade2, treeShade3, boardgame :: PlaceKind rect = PlaceKind -- Valid for any nonempty area, hence low frequency. { psymbol = 'r' @@ -214,4 +214,24 @@ , "sOs" , "XXs" ] + } +boardgame = PlaceKind + { psymbol = 'b' + , pname = "boardgame" + , pfreq = [("boardgame", 1)] + , prarity = [(1, 1)] + , pcover = CVerbatim + , pfence = FNone + , ptopLeft = [ "----------" + , "|.b.b.b.b|" + , "|b.b.b.b.|" + , "|.b.b.b.b|" + , "|b.b.b.b.|" + , "|.b.b.b.b|" + , "|b.b.b.b.|" + , "|.b.b.b.b|" + , "|b.b.b.b.|" + , "----------" + ] + , poverride = [('b', "trailChessLit")] } diff --git a/GameDefinition/Content/RuleKind.hs b/GameDefinition/Content/RuleKind.hs --- a/GameDefinition/Content/RuleKind.hs +++ b/GameDefinition/Content/RuleKind.hs @@ -72,6 +72,5 @@ , rleadLevelClips = 100 , rscoresFile = "scores" , rsavePrefix = "save" - , rsharedStash = True - , rnearby = 10 + , rnearby = 20 } diff --git a/GameDefinition/Content/TileKind.hs b/GameDefinition/Content/TileKind.hs --- a/GameDefinition/Content/TileKind.hs +++ b/GameDefinition/Content/TileKind.hs @@ -207,7 +207,7 @@ } escapeUpLit = TileKind { tsymbol = '<' - , tname = "exit trapdoor up" + , tname = "exit hatch up" , tfreq = [("legendLit", 100)] , tcolor = BrYellow , tcolor2 = BrYellow @@ -265,14 +265,14 @@ } floorRedLit = floorArenaLit { tname = "brick pavement" - , tfreq = [("trailLit", 30)] + , tfreq = [("trailLit", 30), ("trailChessLit", 30)] , tcolor = BrRed , tcolor2 = Red , tfeature = Trail : tfeature floorArenaLit } floorBlueLit = floorRedLit - { tname = "granite cobblestones" - , tfreq = [("trailLit", 100)] + { tname = "cobblestone path" + , tfreq = [("trailLit", 100), ("trailChessLit", 70)] , tcolor = BrBlue , tcolor2 = Blue } @@ -300,7 +300,7 @@ darkFeat (HideAs t) = Just $ HideAs $ darkText t darkFeat (RevealAs t) = Just $ RevealAs $ darkText t darkFeat OftenItem = Nothing -- items not common in the dark - darkFeat feat = Just $ feat + darkFeat feat = Just feat in k { tfreq = darkFrequency , tfeature = Dark : mapMaybe darkFeat (tfeature k) } diff --git a/GameDefinition/PLAYING.md b/GameDefinition/PLAYING.md --- a/GameDefinition/PLAYING.md +++ b/GameDefinition/PLAYING.md @@ -13,8 +13,8 @@ Once the few basic command keys and on-screen symbols are learned, mastery and enjoyment of the game is the matter of tactical skill and literary imagination. To be honest, a lot of imagination is required -for this rudimentary game, even though it is playable and winnable. -Contributions are welcome. +for this rudimentary set of scenarios, even though they are playable +and winnable. Contributions are welcome. Heroes @@ -30,36 +30,40 @@ *@12 Adventurer 4d1+5% Calm: 20/60 HP: 33/50 Target: basilisk [**___] -The line starts with the list of party members (unless only one member -resides on the currently displayed level) and the shortened name of the team. -Then comes the damage of the leader's weapon (but regardless of the figures, -each attack inflicts at least 1 damage), then his current and maximum -Calm (composure, focus, attentiveness), then his current and maximum -HP (hit points, health). At the end, the personal target of the leader -is described, in this case a basilisk monster, with hit points drawn as a bar. +The line starts with the list of party members (unless there's only one member) +and the shortened name of the team. Clicking on the list selects heroes and +the selected run together when `:` or `SHIFT`-left mouse button is pressed. -Weapon damage and other item stats are displayed using the dice notation `XdY`. -which means X rolls of Y-sided dice. A variant denoted 'XdsY' is additionally +Then comes the damage of the highest damage dice weapon the leader can use, +then his current and maximum Calm (composure, focus, attentiveness), then +his current and maximum HP (hit points, health). At the end, the personal +target of the leader is described, in this case a basilisk monster, +with hit points drawn as a bar. Weapon damage and other item stats +are displayed using the dice notation `XdY`, which means X rolls +of Y-sided dice. A variant denoted `XdsY` is additionally scaled by the level depth in proportion to the maximal dungeon depth. +You can read more about combat resolution in section Monsters below. -The second status line describes the current dungeon location in relation +The second status line describes the current level in relation to the party. - 5 Lofty hall [33% seen] Cursor: exact spot (71,12) p15 l10 + 5 Lofty hall [33% seen] X-hair: exact spot (71,12) p15 l10 First comes the depth of the current level and its name. Then the percentage of its explorable tiles already seen by the heroes. -The 'cursor' is the common target of the whole party, -directly manipulated with movement keys in the targeting mode. -At the end comes the length of the shortest path from the leader -to the cursor position and the straight-line distance between the two points. +The 'X-hair' (meaning 'crosshair') is the common focus of the whole party, +denoted on the map by a white box and manipulated with movement keys +in aiming mode. At the end of the status line comes the length of the shortest +path from the leader to the crosshair position and the straight-line distance +between the two points. Dungeon ------- -The dungeon of the campaign mode game consists of 10 levels and each level -consists of a large number of tiles. The basic tile kinds are as follows. +The dungeon of any particular scenario may consists of one or many +levels and each level consists of a large number of tiles. +The basic tile kinds are as follows. dungeon terrain type on-screen symbol ground . @@ -80,10 +84,10 @@ Commands -------- -You move throughout the level using the numerical keypad (left diagram) -or its compact laptop replacement (middle) or Vi text editor keys -(right, also known as "Rogue-like keys", which have to be enabled -in config.ui.ini). +You walk throughout a level using the left mouse button or the numeric +keypad (left diagram) or its compact laptop replacement (middle) +or Vi text editor keys (right, also known as "Rogue-like keys", +which have to be enabled in config.ui.ini). 7 8 9 7 8 9 y k u \|/ \|/ \|/ @@ -91,125 +95,81 @@ /|\ /|\ /|\ 1 2 3 j k l b j n -In targeting mode the keys above move the targeting cursor. In normal mode, -`SHIFT` (or `CTRL`) and a movement key make the current party leader -(and currently selected party members, if any) run in the indicated -direction, until anything of interest is spotted. -The '5', 'i' and '.' keys consume a turn and make you brace for combat, +In aiming mode the same keys (or the middle and right mouse buttons) +move the crosshair (the white box). In normal mode, `SHIFT` (or `CTRL`) +and a movement key make the current party leader run in the indicated +direction, until anything of interest is spotted. The `5` keypad key +and the `i` and `.` keys consume a turn and make you brace for combat, which reduces any damage taken for a turn and makes it impossible for foes to displace you. You displace enemies or friends by bumping -into them with SHIFT (or CTRL). +into them with `SHIFT` (or `CTRL`). Melee, searching for secret doors, looting and opening closed doors can be done by bumping into a monster, a wall and a door, respectively. Few commands other than movement, 'g'etting an item from the floor, 'a'pplying an item and 'f'linging an item are necessary for casual play. -Some are provided only as specialized versions of more general commands -or as building blocks for more complex convenience commands, +Some are provided only as specialized versions of the more general +commands or as building blocks for more complex convenience macros, e.g., the autoexplore command (key `X`) could be defined -by the player as a macro using `BACKSPACE`, `CTRL-?`, `;` and `V`. - -Below are the remaining keys for terrain exploration and alteration. - - keys command - < ascend a level - CTRL-< ascend 10 levels - > descend a level - CTRL-> descend 10 levels - ; make one step towards the target - : go to target for 100 steps - CTRL-: go to target for 10 steps - x explore the closest unknown spot - X autoexplore 100 times - CTRL-X autoexplore 10 times - R rest (wait 100 times) - CTRL-R rest (wait 10 times) - c close door - -Item-use related keys are as follows. - - keys command - E describe equipment of the leader - P describe backpack inventory of the leader - S describe the shared party stash - G describe items on the ground - A describe all owned items - g and , get an item - d drop an item - e equip an item - p pack an item into inventory backpack - s stash and share an item - a activate applicable item - q quaff potion - r read scroll - f fling projectable item - t throw missile - z zap wand - -To make a ranged attack, as in the last few commands above, -you need to set your target first (however, initial target is set -automatically as soon as a monster comes into view). Once in targeting mode, -you can move the targeting cursor with arrow keys and switch focus -among enemies with `*` (or among friends, projectiles and enemies, depending -on targeting mode toggled by `/`). The details of the shared cursor position -and of the personal target are described in the status lines, at the bottom -of the screen. All targeting keys are listed below. +by the player as a macro using `CTRL-?`, `CTRL-.` and `V`. - keys command - KEYPAD_* and \ target enemy - / cycle targeting mode - + swerve targeting line - - unswerve targeting line - BACKSPACE clear target/cursor - CTRL-? target the closest unknown spot - CTRL-I target the closest item - CTRL-{ target the closest stairs up - CTRL-} target the closest stairs down +The following minimal command set lets you accomplish almost anything +in the game, though not necessarily with the fewest number of keystrokes. +The full list of commands can be seen in the in-game help accessible +from the Main Menu. -Here are the commands for automating the actions of one or more members -of the team. + keys command + < ascend a level + > descend a level + c close door + E manage equipment of the leader + g and , get items + a apply consumable + f fling projectile + + swerve the aiming line + D display player diary + T toggle suspect terrain display + SHIFT-TAB cycle among all party members + ESC cancel action, open Main Menu - keys command - = select (or deselect) a party member - _ deselect (or select) all on the level - v voice again the recorded commands - V voice the recorded commands 100 times - CTRL-v voice the recorded commands 1000 times - CTRL-V voice the recorded commands 10 times - ' start recording commands - CTRL-T cycle tactic of non-leader team members (WIP) - CTRL-A automate faction (ESC to retake control) +The only activity not possible with the commands above is the management +of non-leader party members. The defaults should usually suffice, +especially if your non-leader heroes can only melee or wait +and none have found the equipment that enables opportunity fire. +If there's a need, you can manually set party tactics with `CTRL-T` +and you can assign individual targets to party members +using the aiming and targeting commands listed below. -Assorted remaining keys and commands follow. + keys command + KEYPAD_* and \ aim at an enemy + KEYPAD_/ and | cycle aiming styles + + swerve the aiming line + - unswerve the aiming line + CTRL-? set crosshair to the closest unknown spot + CTRL-I set crosshair to the closest item + CTRL-{ set crosshair to the closest stairs up + CTRL-} set crosshair to the closest stairs down + BACKSPACE reset target/crosshair + RET and INSERT accept target/choice - keys command - ? display help - D display player diary - T mark suspect terrain - Z mark visible zone - C mark smell clues - TAB cycle among party members on the level - SHIFT-TAB cycle among all party members - SPACE clear messages - ESC cancel action, open Main Menu - RET accept choice - 0--6 pick a new hero leader anywhere in the dungeon +For ranged attacks, setting the crosshair or individual targets +beforehand is not mandatory, because the crosshair is set automatically +as soon as a monster comes into view and can still be adjusted while +in the missile choice menu. However, if you want to assign persistent +personal targets or just inspect the level map closely, you can enter +the detailed aiming mode with the right mouse button or with +the `*` keypad key that selects enemies or the `/` keypad key that +marks a tile. You can move the aiming crosshair with direction keys +and assign a personal target to the leader with `RET`. +The details of the shared crosshair position and of the personal target +are described in the status lines at the bottom of the screen. Commands for saving and exiting the current game, starting a new game, etc., are listed in the Main Menu, brought up by the `ESC` key. Game difficulty setting affects hitpoints at birth for any actors -of any UI-using faction. For a person new to roguelikes, the Duel game mode +of any UI-using faction. For a person new to roguelikes, the Duel scenario offers a gentle introduction. The subsequent game modes gradually introduce -squad combat, stealth, asymmetric battles and more game elements. - - keys command - CTRL-x save and exit - CTRL-u new Duel game - CTRL-k new Skirmish game - CTRL-m new Ambush game - CTRL-b new Battle game - CTRL-a new Campaign game - CTRL-d cycle next game difficulty +squad combat, stealth, opportunity fire, asymmetric battles and more. Monsters @@ -222,36 +182,50 @@ and all move at once, sometimes brutally colliding by accident. When the hero bumps into a monster or a monster attacks the hero, -melee combat occurs. The best equipped weapon or the best fighting organ -of each opponent is taken into account for calculating damage. -The damage the current hero can potentially inflict is displayed -at the bottom of the screen, but the actual damage depends also -on the monster's armor. Heroes and monsters running into one another +melee combat occurs. Heroes and monsters running into one another (with the `SHIFT` key) do not inflict damage, but change places. This gives the opponent a free blow, but can improve the tactical situation -or aid escape. +or aid escape. In some circumstances actors are immune to the displacing, +e.g., when both parties form a continuous front-line. -Flinging a missile at a target wounds it, consuming the weapon in the process. -You may propel any item in your equipment, inventory and on the ground -(press `?` to see appropriate items in a menu and press it again -for a non-standard choice). Only items of a few kinds inflict any damage, -but some have other effects. Whenever the monster's or hero's hit points -reach zero, the combatant dies. When the last hero dies, the game ends -in defeat. +In melee combat, the best equipped weapon (or the best fighting organ) +of each opponent is taken into account for determining the damage +and any extra effects of the blow. If a recharged weapon with a non-trivial +effect is in the equipment, it is preferred for combat. Otherwise combat +involves the weapon with the highest raw damage dice (the same as displayed +at bottommost status line). +To determine the damage dealt, the outcome of the weapon's damage dice roll +is multiplied by the melee damage bonus (summed from the equipped items +of the attacker) minus the melee armor modifier of the defender. +Regardless of the calculation, each attack inflicts at least 1 damage. +The current leader's melee bonus, armor modifier and other detailed +stats can be viewed via the `!` command. +In ranged combat, the missile is assumed to be attacking the defender +in melee, using itself as the weapon, but the ranged damage bonus +and the ranged armor modifier are taken into account for calculations. +You may propel any item in your equipment, inventory pack and on the ground +(by default you are offered only the appropriate items; press `?` +to cycle item menu modes). Only items of a few kinds inflict any damage, +but some have other effects, beneficial, detrimental or mixed. + +Whenever the monster's or hero's hit points reach zero, the combatant dies. +When the last hero dies, the scenario ends in defeat. + + On Winning and Dying -------------------- -You win the game if you escape the dungeon alive or, in game modes with -no exit opportunity, if you eliminate all opposition. In the former case, -your score is based on the gold and precious gems you've plundered, -plus a bonus based on the number of heroes you lost. In the latter case, -your score is based on the number of turns you spent overcoming your foes -and, as a bonus, the number of enemies you've subdued. +You win the scenario if you escape the dungeon alive or, in scenarios with +no exit locations, if you eliminate all opposition. In the former case, +your score is based on the gold and precious gems you've plundered. +In the latter case, your score is based on the number of turns you spent +overcoming your foes (the quicker the victory, the better; the slower +the demise, the better). Bonus points, based on the number of heroes +that were lost, are awarded if you win. -If all your heroes fall, you are awarded a score for your valiant deeds, -but no winning bonus. When, invariably, a new foolhardy party -of adventurers storms the dungeon, they start from a new entrance, -with no experience and no equipment, and new, undaunted enemies -bar their way. +If all your heroes fall, you will invariably see a new foolhardy party +of adventurers clamoring to be led into the dungeon. They start +their conquest from a new entrance, with no experience and no equipment, +and new, undaunted enemies bar their way. Lead them with fortitude! diff --git a/GameDefinition/TieKnot.hs b/GameDefinition/TieKnot.hs --- a/GameDefinition/TieKnot.hs +++ b/GameDefinition/TieKnot.hs @@ -9,28 +9,40 @@ import qualified Content.PlaceKind import qualified Content.RuleKind import qualified Content.TileKind -import Game.LambdaHack.Client (exeFrontend) +import Game.LambdaHack.Client import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.SampleImplementation.SampleMonadClient (executorCli) import Game.LambdaHack.SampleImplementation.SampleMonadServer (executorSer) -import Game.LambdaHack.Server (mainSer) +import Game.LambdaHack.Server -- | Tie the LambdaHack engine client, server and frontend code -- with the game-specific content definitions, and run the game. tieKnot :: [String] -> IO () -tieKnot args = +tieKnot args = do let -- Common content operations, created from content definitions. - copsServer = Kind.COps - { cocave = Kind.createOps Content.CaveKind.cdefs - , coitem = Kind.createOps Content.ItemKind.cdefs - , comode = Kind.createOps Content.ModeKind.cdefs - , coplace = Kind.createOps Content.PlaceKind.cdefs - , corule = Kind.createOps Content.RuleKind.cdefs - , cotile = Kind.createOps Content.TileKind.cdefs + -- Evaluated fully to discover errors ASAP and free memory. + !copsSlow = Kind.COps + { cocave = Kind.createOps Content.CaveKind.cdefs + , coitem = Kind.createOps Content.ItemKind.cdefs + , comode = Kind.createOps Content.ModeKind.cdefs + , coplace = Kind.createOps Content.PlaceKind.cdefs + , corule = Kind.createOps Content.RuleKind.cdefs + , cotile = Kind.createOps Content.TileKind.cdefs } + !copsShared = speedupCOps False copsSlow -- Client content operations. copsClient = Content.KeyKind.standardKeys - -- A single frontend is currently started by the server, - -- instead of each client starting it's own. - startupFrontend = exeFrontend executorCli executorCli copsClient - in mainSer args copsServer executorSer startupFrontend + sdebugNxt <- debugArgs args + -- Fire up the frontend with the engine fueled by content. + -- The action monad types to be used are determined by the 'exeSer' + -- 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 depends on the flags supplied + -- when compiling the engine library. + let exeServer executorUI executorAI = + executorSer $ loopSer copsShared sdebugNxt executorUI executorAI + -- Currently a single frontend is started by the server, + -- instead of each client starting it's own. + srtFrontend (executorCli . loopUI) + (executorCli . loopAI) + copsClient copsShared (sdebugCli sdebugNxt) exeServer diff --git a/GameDefinition/config.ui.default b/GameDefinition/config.ui.default --- a/GameDefinition/config.ui.default +++ b/GameDefinition/config.ui.default @@ -1,40 +1,40 @@ -; ; This is a commented out copy of the default UI settings config file -; ; that is embedded in the game binary. A user config file can override -; ; these options. Option names are case-sensitive and only ';' for comments -; ; is permitted. -; ; -; ; The game looks for the config file at the same path where saved games -; ; directory is located. E.g. on Linux the file is at -; ; ~/.LambdaHack/config.ui.ini -; ; and on Windows it can be at -; ; C:\Documents And Settings\user\Application Data\LambdaHack\config.ui.ini -; ; or at -; ; C:\Users\\AppData\Roaming\LambdaHack\config.ui.ini -; ; or elsewhere. +; This is a copy of the default UI settings config file +; that is embedded in the game binary. A user config file can override +; these options. Option names are case-sensitive and only ';' for comments +; is permitted. +; +; The game looks for the config file at the same path where saved games +; directory is located. E.g. on Linux the file is at +; ~/.LambdaHack/config.ui.ini +; and on Windows it can be at +; C:\Documents And Settings\user\Application Data\LambdaHack\config.ui.ini +; or at +; C:\Users\\AppData\Roaming\LambdaHack\config.ui.ini +; or elsewhere. -; [extra_commands] -; ; A handy shorthand with Vi keys -; Macro_1 = ("comma", ([CmdItem], Macro "" ["g"])) -; ; Angband compatibility (accept target) -; Macro_2 = ("KP_Insert", ([CmdMeta], Macro "" ["Return"])) +[extra_commands] +; A handy shorthand with Vi keys +Macro_1 = ("comma", ([CmdItem], Macro "" ["g"])) +; Angband compatibility (accept target) +Macro_2 = ("KP_Insert", ([CmdMeta], Macro "" ["Return"])) -; [hero_names] -; HeroName_0 = ("Haskell Alvin", "he") -; HeroName_1 = ("Alonzo Barkley", "he") -; HeroName_2 = ("Ines Galenti", "she") -; HeroName_3 = ("Ernst Abraham", "he") -; HeroName_4 = ("Samuel Saunders", "he") -; HeroName_5 = ("Roger Robin", "he") -; HeroName_6 = ("Christopher Flatt", "he") +[hero_names] +HeroName_0 = ("Haskell Alvin", "he") +HeroName_1 = ("Alonzo Barkley", "he") +HeroName_2 = ("Ines Galenti", "she") +HeroName_3 = ("Ernst Abraham", "he") +HeroName_4 = ("Samuel Saunders", "he") +HeroName_5 = ("Roger Robin", "he") +HeroName_6 = ("Christopher Flatt", "he") -; [ui] -; movementViKeys_hjklyubn = False -; movementLaptopKeys_uk8o79jl = True -; ; Monospace fonts that have fixed size regardless of boldness (on some OSes) -; font = "Terminus,DejaVu Sans Mono,Consolas,Courier New,Liberation Mono,Courier,FreeMono,Monospace normal normal normal normal 16" -; colorIsBold = True -; historyMax = 5000 -; maxFps = 15 -; noAnim = False -; runStopMsgs = False -[dummy] +[ui] +movementViKeys_hjklyubn = False +movementLaptopKeys_uk8o79jl = True +; Monospace fonts that have fixed size regardless of boldness (on some OSes) +font = "Terminus,DejaVu Sans Mono,Consolas,Courier New,Liberation Mono,Courier,FreeMono,Monospace normal normal normal normal 16" +;font = "Terminus,DejaVu Sans Mono,Consolas,Courier New,Liberation Mono,Courier,FreeMono,Monospace normal normal normal normal 20" +colorIsBold = True +historyMax = 5000 +maxFps = 30 +noAnim = False +runStopMsgs = False diff --git a/GameDefinition/scores b/GameDefinition/scores Binary files a/GameDefinition/scores and b/GameDefinition/scores differ diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,5 +1,5 @@ -Copyright (c) 2008--2014 Andres Loeh -Copyright (c) 2010--2014 Mikolaj Konarski +Copyright (c) 2008--2015 Andres Loeh +Copyright (c) 2010--2015 Mikolaj Konarski All rights reserved. diff --git a/LambdaHack.cabal b/LambdaHack.cabal --- a/LambdaHack.cabal +++ b/LambdaHack.cabal @@ -5,7 +5,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.4.100.0 +version: 0.4.101.0 synopsis: A game engine library for roguelike dungeon crawlers description: LambdaHack is a game engine library for roguelike games of arbitrary theme, size and complexity, @@ -21,8 +21,8 @@ Several frontends are available (GTK is the default) and many other generic engine components are easily overridden, but the fundamental source of flexibility lies - in the strict and type-safe separation of code and content - and of clients (human and AI-controlled) and server. + in the strict and type-safe separation of code from the content + and of clients (human and AI-controlled) from the server. Please see the changelog file for recent improvements and the issue tracker for short-term plans. Long term vision revolves around procedural content generation and includes @@ -45,14 +45,14 @@ the module is the exclusive interface to the directory. No references to the modules in the directory are allowed except from the interface module. This policy is only binding - inside the library --- users are free to do whatever they - please, since the library authors are in no position to guess - their particular needs. + when developing the library --- library users are free + to access any modules, since the library authors are in + no position to guess their particular needs. homepage: http://github.com/LambdaHack/LambdaHack bug-reports: http://github.com/LambdaHack/LambdaHack/issues license: BSD3 license-file: LICENSE -tested-with: GHC == 7.6.3, GHC == 7.8 +tested-with: GHC == 7.6, GHC == 7.8 data-files: GameDefinition/config.ui.default, GameDefinition/scores GameDefinition/PLAYING.md, README.md, LICENSE, CREDITS, CHANGELOG.md @@ -83,6 +83,11 @@ default: False manual: True +flag with_expensive_assertions + description: turn on expensive assertions of well-tested code + default: False + manual: True + flag release description: prepare for a release (expose, optimize, etc.) default: True @@ -209,7 +214,7 @@ base >= 4 && < 5, binary >= 0.7 && < 1, bytestring >= 0.9.2 && < 1, - containers >= 0.5 && < 1, + containers >= 0.5.3.0 && < 1, data-default, deepseq >= 1.3 && < 2, directory >= 1.1.0.1 && < 2, @@ -223,7 +228,7 @@ mtl >= 2.0.1 && < 3, old-time >= 1.0.0.7 && < 2, pretty-show >= 1.6 && < 2, - random >= 1.0.1 && < 2, + random >= 1.1 && < 2, stm >= 2.4 && < 3, text >= 0.11.2.3 && < 2, transformers >= 0.3 && < 1, @@ -271,11 +276,14 @@ if flag(expose_internal) cpp-options: -DEXPOSE_INTERNAL + if flag(with_expensive_assertions) + cpp-options: -DWITH_EXPENSIVE_ASSERTIONS + if flag(release) { cpp-options: -DEXPOSE_INTERNAL -- 7.6.3 has broken -O2, apparently if impl(ghc > 7.8) - ghc-options: -O2 + ghc-options: -O2 -fno-ignore-asserts } executable LambdaHack @@ -304,7 +312,7 @@ base >= 4 && < 5, binary >= 0.7 && < 1, bytestring >= 0.9.2 && < 1, - containers >= 0.5 && < 1, + containers >= 0.5.3.0 && < 1, data-default, deepseq >= 1.3 && < 2, directory >= 1.1.0.1 && < 2, @@ -318,7 +326,7 @@ mtl >= 2.0.1 && < 3, old-time >= 1.0.0.7 && < 2, pretty-show >= 1.6 && < 2, - random >= 1.0.1 && < 2, + random >= 1.1 && < 2, stm >= 2.4 && < 3, text >= 0.11.2.3 && < 2, transformers >= 0.3 && < 1, @@ -337,7 +345,7 @@ ghc-options: -threaded "-with-rtsopts=-C0.005" -rtsopts if flag(release) - ghc-options: -O2 "-with-rtsopts=-N1" + ghc-options: -O2 -fno-ignore-asserts "-with-rtsopts=-N1" -- TODO: -N test-suite test @@ -353,7 +361,7 @@ base >= 4 && < 5, binary >= 0.7 && < 1, bytestring >= 0.9.2 && < 1, - containers >= 0.5 && < 1, + containers >= 0.5.3.0 && < 1, data-default, deepseq >= 1.3 && < 2, directory >= 1.1.0.1 && < 2, @@ -367,7 +375,7 @@ mtl >= 2.0.1 && < 3, old-time >= 1.0.0.7 && < 2, pretty-show >= 1.6 && < 2, - random >= 1.0.1 && < 2, + random >= 1.1 && < 2, stm >= 2.4 && < 3, text >= 0.11.2.3 && < 2, transformers >= 0.3 && < 1, @@ -386,5 +394,5 @@ ghc-options: -threaded "-with-rtsopts=-C0.005" -rtsopts if flag(release) - ghc-options: -O2 "-with-rtsopts=-N1" + ghc-options: -O2 -fno-ignore-asserts "-with-rtsopts=-N1" -- TODO: -N diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -23,116 +23,19 @@ xcfrontendBattle: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --maxFps 60 --dumpInitRngs --automateAll --gameMode battle --difficulty 2 +xcfrontendBattleSurvival: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --maxFps 60 --dumpInitRngs --automateAll --gameMode "battle survival" --difficulty 8 + xcfrontendSafari: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --maxFps 60 --dumpInitRngs --automateAll --gameMode safari --difficulty 2 +xcfrontendSafariSurvival: + dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --maxFps 60 --dumpInitRngs --automateAll --gameMode "safari survival" --difficulty 8 + xcfrontendDefense: dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --maxFps 60 --dumpInitRngs --automateAll --gameMode defense --difficulty 8 -xcbenchCampaign: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --gameMode campaign --difficulty 2 --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS -xcbenchBattle: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --gameMode battle --difficulty 2 --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS - -xcbenchFrontendCampaign: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --maxFps 100000 --benchmark --stopAfter 60 --automateAll --gameMode campaign --difficulty 2 --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS - -xcbenchFrontendBattle: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --maxFps 100000 --benchmark --stopAfter 60 --automateAll --gameMode battle --difficulty 2 --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS - -xcbenchNull: xcbenchCampaign xcbenchBattle - -xcbench: xcbenchCampaign xcbenchFrontendCampaign xcbenchBattle xcbenchFrontendBattle - - -xctest-travis-short: xctest-short - -xctest-travis: xctest-short xctest-medium - -xctest-travis-long: xctest-short xctest-long - -xctest-travis-long-no-safari: xctest-short xctest-long-no-safari - -xctest: xctest-short xctest-medium xctest-long - -xctest-short: xctest-short-new xctest-short-load - -xctest-medium: xctestCampaign-medium xctestSkirmish-medium xctestAmbush-medium xctestBattle-medium xctestSafari-medium xctestPvP-medium xctestCoop-medium xctestDefense-medium - -xctest-long: xctestCampaign-long xctestSkirmish-medium xctestAmbush-medium xctestBattle-long xctestSafari-long xctestPvP-medium xctestDefense-long - -xctest-long-no-safari: xctestCampaign-long xctestSkirmish-medium xctestAmbush-medium xctestBattle-long xctestPvP-medium xctestDefense-long - -xctestCampaign-long: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --gameMode campaign --difficulty 2 > /tmp/stdtest.log - -xctestCampaign-medium: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode campaign --difficulty 2 > /tmp/stdtest.log - -xctestSkirmish-long: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode skirmish > /tmp/stdtest.log - -xctestSkirmish-medium: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode skirmish > /tmp/stdtest.log - -xctestAmbush-long: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode ambush > /tmp/stdtest.log - -xctestAmbush-medium: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode ambush > /tmp/stdtest.log - -xctestBattle-long: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 200 --dumpInitRngs --automateAll --gameMode battle --difficulty 2 > /tmp/stdtest.log - -xctestBattle-medium: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 100 --dumpInitRngs --automateAll --gameMode battle --difficulty 2 > /tmp/stdtest.log - -xctestSafari-long: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --gameMode safari --difficulty 2 > /tmp/stdtest.log - -xctestSafari-medium: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode safari --difficulty 2 > /tmp/stdtest.log - -xctestPvP-long: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode PvP > /tmp/stdtest.log - -xctestPvP-medium: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode PvP > /tmp/stdtest.log - -xctestCoop-long: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --gameMode Coop --difficulty 2 > /tmp/stdtest.log - -xctestCoop-medium: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 300 --dumpInitRngs --automateAll --gameMode Coop --difficulty 2 > /tmp/stdtest.log - -xctestDefense-long: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --gameMode defense --difficulty 8 > /tmp/stdtest.log - -xctestDefense-medium: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 300 --dumpInitRngs --automateAll --gameMode defense --difficulty 8 > /tmp/stdtest.log - -xctest-short-new: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix campaign --dumpInitRngs --automateAll --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix skirmish --dumpInitRngs --automateAll --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix ambush --dumpInitRngs --automateAll --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix battle --dumpInitRngs --automateAll --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix safari --dumpInitRngs --automateAll --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix PvP --dumpInitRngs --automateAll --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix Coop --dumpInitRngs --automateAll --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix defense --dumpInitRngs --automateAll --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log - -xctest-short-load: - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix campaign --dumpInitRngs --automateAll --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix skirmish --dumpInitRngs --automateAll --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix ambush --dumpInitRngs --automateAll --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix battle --dumpInitRngs --automateAll --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix safari --dumpInitRngs --automateAll --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix PvP --dumpInitRngs --automateAll --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix Coop --dumpInitRngs --automateAll --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix defense --dumpInitRngs --automateAll --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log - - play: dist/build/LambdaHack/LambdaHack --dbgMsgSer --dumpInitRngs @@ -148,23 +51,29 @@ frontendBattle: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 60 --dumpInitRngs --automateAll --gameMode battle --difficulty 2 +frontendBattleSurvival: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 60 --dumpInitRngs --automateAll --gameMode "battle survival" --difficulty 8 + frontendSafari: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 60 --dumpInitRngs --automateAll --gameMode safari --difficulty 2 +frontendSafariSurvival: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 60 --dumpInitRngs --automateAll --gameMode "safari survival" --difficulty 8 + frontendDefense: dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 60 --dumpInitRngs --automateAll --gameMode defense --difficulty 8 benchCampaign: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --gameMode campaign --difficulty 2 --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --keepAutomated --gameMode campaign --difficulty 2 --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS benchBattle: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --gameMode battle --difficulty 2 --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --keepAutomated --gameMode battle --difficulty 2 --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS benchFrontendCampaign: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 100000 --benchmark --stopAfter 60 --automateAll --gameMode campaign --difficulty 2 --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 100000 --benchmark --stopAfter 60 --automateAll --keepAutomated --gameMode campaign --difficulty 2 --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS benchFrontendBattle: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 100000 --benchmark --stopAfter 60 --automateAll --gameMode battle --difficulty 2 --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 100000 --benchmark --stopAfter 60 --automateAll --keepAutomated --gameMode battle --difficulty 2 --setDungeonRng 42 --setMainRng 42 +RTS -N1 -RTS benchNull: benchCampaign benchBattle @@ -173,8 +82,10 @@ test-travis-short: test-short -test-travis: test-short test-medium +test-travis-medium: test-short test-medium +test-travis-medium-no-safari: test-short test-medium-no-safari + test-travis-long: test-short test-long test-travis-long-no-safari: test-short test-long-no-safari @@ -183,79 +94,98 @@ test-short: test-short-new test-short-load -test-medium: testCampaign-medium testSkirmish-medium testAmbush-medium testBattle-medium testSafari-medium testPvP-medium testCoop-medium testDefense-medium +test-medium: testCampaign-medium testSkirmish-medium testAmbush-medium testBattle-medium testBattleSurvival-medium testSafari-medium testSafariSurvival-medium testPvP-medium testCoop-medium testDefense-medium -test-long: testCampaign-long testSkirmish-medium testAmbush-medium testBattle-long testSafari-long testPvP-medium testDefense-long +test-medium-no-safari: testCampaign-medium testSkirmish-medium testAmbush-medium testBattle-medium testBattleSurvival-medium testPvP-medium testCoop-medium testDefense-medium -test-long-no-safari: testCampaign-long testSkirmish-medium testAmbush-medium testBattle-long testPvP-medium testDefense-long +test-long: testCampaign-long testSkirmish-medium testAmbush-medium testBattle-long testBattleSurvival-long testSafari-long testSafariSurvival-long testPvP-medium testDefense-long +test-long-no-safari: testCampaign-long testSkirmish-medium testAmbush-medium testBattle-long testBattleSurvival-long testPvP-medium testDefense-long + testCampaign-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --gameMode campaign --difficulty 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --keepAutomated --gameMode campaign --difficulty 2 > /tmp/stdtest.log testCampaign-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode campaign --difficulty 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --keepAutomated --gameMode campaign --difficulty 2 > /tmp/stdtest.log testSkirmish-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode skirmish > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --keepAutomated --gameMode skirmish > /tmp/stdtest.log testSkirmish-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode skirmish > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --keepAutomated --gameMode skirmish > /tmp/stdtest.log testAmbush-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode ambush > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --keepAutomated --gameMode ambush > /tmp/stdtest.log testAmbush-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode ambush > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --keepAutomated --gameMode ambush > /tmp/stdtest.log testBattle-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 200 --dumpInitRngs --automateAll --gameMode battle --difficulty 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 100 --dumpInitRngs --automateAll --keepAutomated --gameMode battle --difficulty 2 > /tmp/stdtest.log testBattle-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 100 --dumpInitRngs --automateAll --gameMode battle --difficulty 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 50 --dumpInitRngs --automateAll --keepAutomated --gameMode battle --difficulty 2 > /tmp/stdtest.log +testBattleSurvival-long: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 100 --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" --difficulty 8 > /tmp/stdtest.log + +testBattleSurvival-medium: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 50 --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" --difficulty 8 > /tmp/stdtest.log + testSafari-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --gameMode safari --difficulty 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --keepAutomated --gameMode safari --difficulty 2 > /tmp/stdtest.log testSafari-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode safari --difficulty 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 200 --dumpInitRngs --automateAll --keepAutomated --gameMode safari --difficulty 2 > /tmp/stdtest.log +testSafariSurvival-long: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --difficulty 8 > /tmp/stdtest.log + +testSafariSurvival-medium: + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 200 --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --difficulty 8 > /tmp/stdtest.log + + testPvP-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode PvP > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --keepAutomated --gameMode PvP > /tmp/stdtest.log testPvP-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode PvP > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --keepAutomated --gameMode PvP > /tmp/stdtest.log testCoop-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --gameMode Coop --difficulty 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --keepAutomated --gameMode Coop --difficulty 2 > /tmp/stdtest.log testCoop-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 300 --dumpInitRngs --automateAll --gameMode Coop --difficulty 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 300 --dumpInitRngs --automateAll --keepAutomated --gameMode Coop --difficulty 2 > /tmp/stdtest.log testDefense-long: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --gameMode defense --difficulty 8 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 500 --dumpInitRngs --automateAll --keepAutomated --gameMode defense --difficulty 8 > /tmp/stdtest.log testDefense-medium: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 300 --dumpInitRngs --automateAll --gameMode defense --difficulty 8 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 300 --dumpInitRngs --automateAll --keepAutomated --gameMode defense --difficulty 8 > /tmp/stdtest.log test-short-new: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix campaign --dumpInitRngs --automateAll --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix skirmish --dumpInitRngs --automateAll --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix ambush --dumpInitRngs --automateAll --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix battle --dumpInitRngs --automateAll --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix safari --dumpInitRngs --automateAll --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix PvP --dumpInitRngs --automateAll --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix Coop --dumpInitRngs --automateAll --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix defense --dumpInitRngs --automateAll --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix campaign --dumpInitRngs --automateAll --keepAutomated --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix skirmish --dumpInitRngs --automateAll --keepAutomated --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix battleSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix PvP --dumpInitRngs --automateAll --keepAutomated --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix Coop --dumpInitRngs --automateAll --keepAutomated --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix defense --dumpInitRngs --automateAll --keepAutomated --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log test-short-load: - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix campaign --dumpInitRngs --automateAll --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix skirmish --dumpInitRngs --automateAll --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix ambush --dumpInitRngs --automateAll --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix battle --dumpInitRngs --automateAll --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix safari --dumpInitRngs --automateAll --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix PvP --dumpInitRngs --automateAll --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix Coop --dumpInitRngs --automateAll --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log - dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix defense --dumpInitRngs --automateAll --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix campaign --dumpInitRngs --automateAll --keepAutomated --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix skirmish --dumpInitRngs --automateAll --keepAutomated --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix battle --dumpInitRngs --automateAll --keepAutomated --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix battleSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "battle survival" --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix safari --dumpInitRngs --automateAll --keepAutomated --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix safariSurvival --dumpInitRngs --automateAll --keepAutomated --gameMode "safari survival" --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix PvP --dumpInitRngs --automateAll --keepAutomated --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix Coop --dumpInitRngs --automateAll --keepAutomated --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log + dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix defense --dumpInitRngs --automateAll --keepAutomated --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log build-binary: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -59,7 +59,7 @@ --------------------------------- The game UI can be configured via a config file. -The commented out version of this file with the default settings is in +A file with the default settings, the same as built into the binary, is in [GameDefinition/config.ui.default](GameDefinition/config.ui.default). When the game is run for the first time, the file is copied to the official location, which is `~/.LambdaHack/config.ui.ini` on Linux and @@ -67,29 +67,29 @@ (or `C:\Documents And Settings\user\Application Data\LambdaHack\config.ui.ini` or something else altogether) on Windows. -Screen font can be changed and enlarged by uncommenting and editing -the config file at its official location or by right-clicking -on the game window. +Screen font can be changed and enlarged by editing the config file +at its official location or by CTRL-right-clicking on the game window. If you use the numeric keypad, use the NumLock key on your keyboard to toggle the game keyboard mode. With NumLock off, you walk with the numeric -keys and run with Shift (or Control) and the keys. When you turn NumLock on, +keys and run with Shift (or Control) and the keys. This mode is probably +the best if you use mouse for running. When you turn NumLock on, the reversed key setup enforces good playing habits by setting as the default the run command (which automatically stops at threats, keeping you safe) and requiring Shift for the error-prone step by step walking. -If you don't have a numeric keypad, you can use laptop keys (uk8o79jl) +If you don't have the numeric keypad, you can use laptop keys (uk8o79jl) or you can enable the Vi keys (aka roguelike keys) in the config file. Compilation from source ----------------------- -The library is best compiled and installed via Cabal (already a part -of your OS distribution, or available within [The Haskell Platform] [7]), -which also takes care of all the dependencies. You also need -the GTK libraries for your OS. On Linux, remember to install the -dev -versions as well. On Windows follow [the same steps as for Wine] [13]. +If you want to compile your own binaries from the source code, +use Cabal (already a part of your OS distribution, or available within +[The Haskell Platform] [7]), which also takes care of all the dependencies. +You also need the GTK libraries for your OS. On Linux, remember to install +the -dev versions as well. 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]. @@ -97,41 +97,41 @@ compiled and installed automatically by Cabal from [Hackage] [3] as follows cabal install gtk2hs-buildtools - cabal install LambdaHack + cabal install LambdaHack --force-reinstalls For a newer snapshot, download source from a development branch at [github] [5] and run Cabal from the main directory cabal install gtk2hs-buildtools - cabal install + cabal install --force-reinstalls For the example game, the best frontend (wrt keyboard support and colours) is the default gtk. To compile with one of the terminal frontends, use Cabal flags, e.g, - cabal install -fvty + cabal install -fvty --force-reinstalls Compatibility notes ------------------- -The current code was tested with GHC 7.6 and 7.8, -but should also work with other GHC versions, with minor modifications. - -If you are using the terminal frontends, numerical keypad may not work +If you are using a terminal frontend, numeric keypad may not work correctly depending on versions of the libraries, terminfo and terminal emulators. The curses frontend is not fully supported due to the limitations -of the curses library. With the vty frontend run in an xterm, +of the curses library. With the vty frontend started in an xterm, CTRL-keypad keys for running seem to work OK, but on rxvt they do not. -Laptop (uk8o79jl) and Vi keys (hjklyubn, if enabled in config.ui.ini) -should work everywhere regardless. GTK works fine, too. +The commands that require pressing CTRL and SHIFT together won't +work either, but fortunately they are not crucial to gameplay. +For movement, laptop (uk8o79jl) and Vi keys (hjklyubn, if enabled +in config.ui.ini) should work everywhere. GTK works fine, too, both +with numeric keypad and with mouse. Testing and debugging --------------------- The [Makefile](Makefile) contains many sample test commands. -Many tests that use the screensaver game modes (AI vs. AI) +Numerous tests that use the screensaver game modes (AI vs. AI) and the dumb `stdout` frontend are gathered in `make test`. Of these, travis runs `test-travis-*` on each push to the repo. Test commands with prefix `frontend` start AI vs. AI games @@ -155,8 +155,8 @@ hpc markup --hpcdir=dist/hpc/mix/LambdaHack-xxx/ LambdaHack Note that debug option `--stopAfter` is required to cleanly terminate -any automated test that is used to gather HPC info, because HPC needs -a clean exit (to save data files). +any automated test. This is needed to gather any HPC info, because HPC +requires a clean exit to save data files. Further information diff --git a/test/test.hs b/test/test.hs --- a/test/test.hs +++ b/test/test.hs @@ -1,6 +1,6 @@ import TieKnot main :: IO () -main = do +main = tieKnot $ tail $ words "dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 6 --automateAll --gameMode campaign --setDungeonRng 42 --setMainRng 42" -- tieKnot $ tail $ words "dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 6 --automateAll --gameMode battle --setDungeonRng 42 --setMainRng 42"