packages feed

LambdaHack 0.2.12 → 0.2.14

raw patch · 182 files changed

+20516/−14119 lines, 182 filesdep +asyncbinary-added

Dependencies added: async

Files

+ CHANGELOG.md view
@@ -0,0 +1,86 @@+## [v0.2.14, aka 'Out of balance'](https://github.com/LambdaHack/LambdaHack/compare/v0.2.12...v0.2.14)++- tons of new (unbalanced) content, content fields, effects and descriptions+- add a simple cabal test in addition to make-test and travis-test+- generate items and actors according to their rarities at various depths+- redo weapon choice, combat bonuses and introduce armor+- introduce skill levels for abilities (boolean for now, WIP)+- remove regeneration, re-add through periodically activating items+- ensure passable areas of randomly filled caves are well connected+- make secondary factions leaderless+- auto-tweak digital line epsilon to let projectiles evade obstacles+- add shrapnel (explosions) and organs (body parts)+- express actor kinds as item kinds (their trunk)+- add dynamic lights through items, actors, projectiles+- fix and improve item kind and item stats identification+- make aspects additive from all equipment and organ items+- split item effects into aspects, effects and item features+- rework AI and structure it according to the Ability type+- define Num instance for Dice to make writing it in content easier+- remove the shared screen multiplayer mode and all support code, for now+- rename all modules and nearly all other code entities+- check and consume HP when calling friends and Calm when summoning+- determine sight radius from items and cap it at current Calm/5+- introduce Calm; use to hear nearby enemies and limit item abuse before death+- let AI actors manage items and share them with party members+- completely revamp item manipulation UI+- add a command to cede control to AI+- separate actor inventory, 10-item actor equipment and shared party stash+- vi movement keys (hjklyubn) are now disabled by default+- new movement keyset: laptop movement keys (uk8o79jl)++## [v0.2.12](https://github.com/LambdaHack/LambdaHack/compare/v0.2.10...v0.2.12)++- improve and simplify dungeon generation+- simplify running and permit multi-actor runs+- let items explode and generate shrapnel projectiles+- add game difficulty setting (initial HP scaling right now)+- allow recording, playing back and looping commands+- implement pathfinding via per-actor BFS over the whole level+- extend setting targets for actors in UI tremendously+- implement autoexplore, go-to-target, etc., as macros+- let AI use pathfinding, switch leaders, pick levels to swarm to+- force level/leader changes on spawners (even when played by humans)+- extend and redesign UI bottom status lines+- get rid of CPS style monads, aborts and WriterT+- benchmark and optimize the code, in particular using Data.Vector+- split off and use the external library assert-failure+- simplify config files and limit the number of external dependencies++## [v0.2.10](https://github.com/LambdaHack/LambdaHack/compare/v0.2.8...v0.2.10)++- screensaver game modes (AI vs AI)+- improved AI (can now climbs stairs, etc.)+- multiple, multi-floor staircases+- multiple savefiles+- configurable framerate and combat animations++## [v0.2.8](https://github.com/LambdaHack/LambdaHack/compare/v0.2.6.5...v0.2.8)++- cooperative and competitive multiplayer (shared-screen only in this version)+- overhauled searching+- rewritten engine code to have a single server that sends restricted game state updates to many fat clients, while a thin frontend layer multiplexes visuals from a subset of the clients++## [v0.2.6.5](https://github.com/LambdaHack/LambdaHack/compare/v0.2.6...v0.2.6.5)++- this is a minor release, primarily intended to fix the broken haddock documentation on Hackage+- changes since 0.2.6 are mostly unrelated to gameplay:+    - strictly typed config files split into UI and rules+    - a switch from Text to String throughout the codebase+    - use of the external library miniutter for English sentence generation++## [v0.2.6](https://github.com/LambdaHack/LambdaHack/compare/v0.2.1...v0.2.6)++- the Main Menu+- improved and configurable mode of squad combat++## [v0.2.1](https://github.com/LambdaHack/LambdaHack/compare/v0.2.0...v0.2.1)++- missiles flying for three turns (by an old kosmikus' idea)+- visual feedback for targeting+- animations of combat and individual monster moves++## [v0.2.0](https://github.com/LambdaHack/LambdaHack/compare/release-0.1.20110918...v0.2.6)++- the LambdaHack engine becomes a Haskell library+- the LambdaHack game depends on the engine library
+ Game/LambdaHack/Atomic.hs view
@@ -0,0 +1,17 @@+-- | Atomic game state transformations. TODO: haddocks.+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Atomic+  ( -- * Re-exported from MonadAtomic+    MonadAtomic(..)+  , broadcastUpdAtomic, broadcastSfxAtomic+    -- * Re-exported from CmdAtomic+  , CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), HitAtomic(..)+    -- * Re-exported from PosAtomicRead+  , PosAtomic(..), posUpdAtomic, posSfxAtomic, seenAtomicCli, generalMoveItem+  ) where++import Game.LambdaHack.Atomic.CmdAtomic+import Game.LambdaHack.Atomic.MonadAtomic+import Game.LambdaHack.Atomic.PosAtomicRead
+ Game/LambdaHack/Atomic/BroadcastAtomicWrite.hs view
@@ -0,0 +1,183 @@+-- | Sending atomic commands to clients and executing them on the server.+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Atomic.BroadcastAtomicWrite+  ( handleAndBroadcast+  ) where++import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Key (mapWithKeyM_)+import Data.Maybe++import Game.LambdaHack.Atomic.CmdAtomic+import Game.LambdaHack.Atomic.HandleAtomicWrite+import Game.LambdaHack.Atomic.MonadStateWrite+import Game.LambdaHack.Atomic.PosAtomicRead+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.Response+import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.ModeKind++-- TODO: split into simpler pieces++--storeUndo :: MonadServer m => CmdAtomic -> m ()+--storeUndo _atomic =+--  maybe skip (\a -> modifyServer $ \ser -> ser {sundo = a : sundo ser})+--    $ Nothing   -- TODO: undoCmdAtomic atomic++handleCmdAtomicServer :: forall m. MonadStateWrite m+                      => PosAtomic -> CmdAtomic -> m ()+handleCmdAtomicServer posAtomic atomic =+  when (seenAtomicSer posAtomic) $ do+--    storeUndo atomic+    handleCmdAtomic atomic++-- | Send an atomic action to all clients that can see it.+handleAndBroadcast :: forall m a. MonadStateWrite m+                   => Bool -> Pers+                   -> (a -> FactionId -> LevelId -> m Perception)+                   -> m a+                   -> (FactionId -> ResponseAI -> m ())+                   -> (FactionId -> ResponseUI -> m ())+                   -> CmdAtomic+                   -> m ()+handleAndBroadcast knowEvents persOld doResetFidPerception doResetLitInDungeon+                   doSendUpdateAI doSendUpdateUI atomic = do+  -- Gather data from the old state.+  sOld <- getState+  factionD <- getsState sfactionD+  (ps, resets, atomicBroken, psBroken) <-+    case atomic of+      UpdAtomic cmd -> do+        ps <- posUpdAtomic cmd+        let resets = resetsFovCmdAtomic cmd+        atomicBroken <- breakUpdAtomic cmd+        psBroken <- mapM posUpdAtomic atomicBroken+        return (ps, resets, map UpdAtomic atomicBroken, psBroken)+      SfxAtomic sfx -> do+        ps <- posSfxAtomic sfx+        atomicBroken <- breakSfxAtomic sfx+        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+  -- Perform the action on the server.+  handleCmdAtomicServer ps atomic+  -- Update lights in the dungeon. This is lazy, may not be needed or partially.+  persLit <- doResetLitInDungeon+  -- Send some actions to the clients, one faction at a time.+  let sendUI fid cmdUI =+        when (playerUI $ gplayer $ factionD EM.! fid) $ doSendUpdateUI fid cmdUI+      sendAI fid cmdAI = doSendUpdateAI fid cmdAI+      sendA fid cmd = do+        sendUI fid $ RespUpdAtomicUI cmd+        sendAI fid $ RespUpdAtomicAI cmd+      sendUpdate fid (UpdAtomic cmd) = sendA fid cmd+      sendUpdate fid (SfxAtomic sfx) = sendUI fid $ RespSfxAtomicUI sfx+      breakSend lid fid perNew = do+        let send2 (atomic2, ps2) =+              if seenAtomicCli knowEvents fid perNew ps2+                then sendUpdate fid atomic2+                else do+                  mleader <- getsState $ gleader . (EM.! fid) . sfactionD+                  case (atomic2, mleader) of+                    (UpdAtomic cmd, Just leader) -> do+                      body <- getsState $ getActorBody leader+                      loud <- loudUpdAtomic (blid body == lid) fid cmd+                      case loud of+                        Nothing -> return ()+                        Just msg -> sendUpdate fid $ SfxAtomic $ SfxMsgAll msg+                    _ -> return ()+        mapM_ send2 atomicPsBroken+      anySend lid fid perOld perNew = do+        let startSeen = seenAtomicCli knowEvents fid perOld ps+            endSeen = seenAtomicCli knowEvents fid perNew ps+        if startSeen && endSeen+          then sendUpdate fid atomic+          else breakSend lid fid perNew+      posLevel fid lid = do+        let perOld = persOld EM.! fid EM.! lid+        if resets then do+          perNew <- doResetFidPerception persLit fid lid+          let inPer = diffPer perNew perOld+              outPer = diffPer perOld perNew+          if nullPer outPer && nullPer inPer+            then anySend lid fid perOld perOld+            else do+              unless knowEvents $ do  -- inconsistencies would quickly manifest+                sendA fid $ UpdPerception lid outPer inPer+                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+                -- Verify that we remember only new things.+                assert (allB (not . seenOld) psRem) skip+                mapM_ (sendA fid) remember+              anySend lid fid perOld perNew+        else anySend lid fid perOld perOld+      send fid = case ps of+        PosSight lid _ -> posLevel fid lid+        PosFidAndSight _ lid _ -> posLevel fid lid+        -- In the following cases, from the assertion above,+        -- @resets@ is false here and broken atomic has the same ps.+        PosSmell lid _ -> do+          let perOld = persOld EM.! fid EM.! lid+          anySend lid fid perOld perOld+        PosFid fid2 -> when (fid == fid2) $ sendUpdate fid atomic+        PosFidAndSer Nothing fid2 -> when (fid == fid2) $ sendUpdate fid atomic+        PosFidAndSer (Just lid) _ -> posLevel fid lid+        PosSer -> return ()+        PosAll -> sendUpdate fid atomic+        PosNone -> return ()+  mapWithKeyM_ (\fid _ -> send fid) factionD++atomicRemember :: LevelId -> Perception -> State -> [UpdAtomic]+atomicRemember lid inPer s =+  -- No @UpdLoseItem@ is sent for items that became out of sight.+  -- The client will create these atomic actions based on @outPer@,+  -- if required. Any client that remembers out of sight items, OTOH,+  -- will create atomic actions that forget remembered items+  -- that are revealed not to be there any more (no @UpdSpotItem@ for them).+  -- Similarly no @UpdLoseActor@, @UpdLoseTile@ nor @UpdLoseSmell@.+  let inFov = ES.elems $ totalVisible inPer+      lvl = sdungeon s EM.! lid+      -- Actors.+      inPrio = concatMap (\p -> posToActors p lid s) inFov+      fActor ((aid, b), ais) = UpdSpotActor aid b ais+      inActor = map fActor inPrio+      -- Items.+      pMaybe p = maybe Nothing (\x -> Just (p, x))+      inFloor = mapMaybe (\p -> pMaybe p $ EM.lookup p (lfloor lvl)) inFov+      fItem p (iid, k) = UpdSpotItem iid (getItemBody iid s) k (CFloor lid p)+      fBag (p, bag) = map (fItem p) $ EM.assocs bag+      inItem = concatMap fBag inFloor+      -- Tiles.+      cotile = Kind.cotile (scops s)+      inTileMap = map (\p -> (p, hideTile cotile lvl p)) inFov+      atomicTile = if null inTileMap then [] else [UpdSpotTile lid inTileMap]+      -- Smells.+      inSmellFov = ES.elems $ smellVisible inPer+      inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl)) inSmellFov+      atomicSmell = if null inSm then [] else [UpdSpotSmell lid inSm]+  in inItem ++ inActor ++ atomicTile ++ atomicSmell
+ Game/LambdaHack/Atomic/CmdAtomic.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE DeriveGeneric #-}+-- | A set of atomic commands shared by client and server.+-- These are the largest building blocks that have no components+-- that can be observed in isolation.+--+-- We try to make atomic commands respect the laws of energy and mass+-- conservation, unless they really can't, e.g., monster spawning.+-- For example item removal from inventory is not an atomic command,+-- but item dropped from the inventory to the ground is. This makes+-- it easier to undo the commands. In principle, the commands are the only+-- way to affect the basic game state (@State@).+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Atomic.CmdAtomic+  ( CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), HitAtomic(..)+  , undoUpdAtomic, undoSfxAtomic, undoCmdAtomic+  ) where++import Data.Binary+import Data.Int (Int64)+import Data.Text (Text)+import GHC.Generics (Generic)++import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Common.Color as Color+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ItemKind as ItemKind+import Game.LambdaHack.Content.TileKind as TileKind++data CmdAtomic =+    UpdAtomic !UpdAtomic+  | SfxAtomic !SfxAtomic+  deriving (Show, Eq, Generic)++instance Binary CmdAtomic++-- | Abstract syntax of atomic commands.+data UpdAtomic =+  -- Create/destroy actors and items.+    UpdCreateActor !ActorId !Actor ![(ItemId, Item)]+  | UpdDestroyActor !ActorId !Actor ![(ItemId, Item)]+  | UpdCreateItem !ItemId !Item !Int !Container+  | UpdDestroyItem !ItemId !Item !Int !Container+  | UpdSpotActor !ActorId !Actor ![(ItemId, Item)]+  | UpdLoseActor !ActorId !Actor ![(ItemId, Item)]+  | UpdSpotItem !ItemId !Item !Int !Container+  | UpdLoseItem !ItemId !Item !Int !Container+  -- Move actors and items.+  | UpdMoveActor !ActorId !Point !Point+  | UpdWaitActor !ActorId !Bool+  | UpdDisplaceActor !ActorId !ActorId+  | UpdMoveItem !ItemId !Int !ActorId !CStore !CStore+  -- Change actor attributes.+  | UpdAgeActor !ActorId !(Delta Time)+  | UpdRefillHP !ActorId !Int64+  | UpdRefillCalm !ActorId !Int64+  | UpdOldFidActor !ActorId !FactionId !FactionId+  | UpdTrajectory !ActorId+                       !(Maybe ([Vector], Speed))+                       !(Maybe ([Vector], Speed))+  | UpdColorActor !ActorId !Color.Color !Color.Color+  -- Change faction attributes.+  | UpdQuitFaction !FactionId !(Maybe Actor) !(Maybe Status) !(Maybe Status)+  | UpdLeadFaction !FactionId !(Maybe ActorId) !(Maybe ActorId)+  | UpdDiplFaction !FactionId !FactionId !Diplomacy !Diplomacy+  | UpdAutoFaction !FactionId !Bool+  | UpdRecordKill !ActorId !(Kind.Id ItemKind) !Int+  -- Alter map.+  | UpdAlterTile !LevelId !Point !(Kind.Id TileKind) !(Kind.Id TileKind)+  | UpdAlterClear !LevelId !Int+  | UpdSearchTile !ActorId !Point !(Kind.Id TileKind) !(Kind.Id TileKind)+  | UpdLearnSecrets !ActorId !Int !Int+  | UpdSpotTile !LevelId ![(Point, Kind.Id TileKind)]+  | UpdLoseTile !LevelId ![(Point, Kind.Id TileKind)]+  | UpdAlterSmell !LevelId !Point !(Maybe Time) !(Maybe Time)+  | UpdSpotSmell !LevelId ![(Point, Time)]+  | UpdLoseSmell !LevelId ![(Point, Time)]+  -- Assorted.+  | 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+  | UpdPerception !LevelId !Perception !Perception+  | UpdRestart !FactionId !Discovery !FactionPers !State !DebugModeCli !Text+  | UpdRestartServer !State+  | UpdResume !FactionId !FactionPers+  | UpdResumeServer !State+  | UpdKillExit !FactionId+  | UpdSaveBkp+  | UpdMsgAll !Msg+  | UpdRecordHistory !FactionId+  deriving (Show, Eq, Generic)++instance Binary UpdAtomic++-- | Abstract syntax of atomic special effects.+data SfxAtomic =+    SfxStrike !ActorId !ActorId !ItemId !HitAtomic+  | SfxRecoil !ActorId !ActorId !ItemId !HitAtomic+  | SfxProject !ActorId !ItemId+  | SfxCatch !ActorId !ItemId+  | SfxActivate !ActorId !ItemId !Int+  | SfxCheck !ActorId !ItemId !Int+  | SfxTrigger !ActorId !Point !F.Feature+  | SfxShun !ActorId !Point !F.Feature+  | SfxEffect !FactionId !ActorId !(Effect.Effect Int)+  | SfxMsgFid !FactionId !Msg+  | SfxMsgAll !Msg+  | SfxActorStart !ActorId+  deriving (Show, Eq, Generic)++instance Binary SfxAtomic++data HitAtomic = HitClear | HitBlock !Int+  deriving (Show, Eq, Generic)++instance Binary HitAtomic++undoUpdAtomic :: UpdAtomic -> Maybe UpdAtomic+undoUpdAtomic cmd = case cmd of+  UpdCreateActor aid body ais -> Just $ UpdDestroyActor aid body ais+  UpdDestroyActor aid body ais -> Just $ UpdCreateActor aid body ais+  UpdCreateItem iid item k c -> Just $ UpdDestroyItem iid item k c+  UpdDestroyItem iid item k c -> Just $ UpdCreateItem iid item k c+  UpdSpotActor aid body ais -> Just $ UpdLoseActor aid body ais+  UpdLoseActor aid body ais -> Just $ UpdSpotActor aid body ais+  UpdSpotItem iid item k c -> Just $ UpdLoseItem iid item k c+  UpdLoseItem iid item k c -> Just $ UpdSpotItem iid item k c+  UpdMoveActor aid fromP toP -> Just $ UpdMoveActor aid toP fromP+  UpdWaitActor aid toWait -> Just $ UpdWaitActor aid (not toWait)+  UpdDisplaceActor source target -> Just $ UpdDisplaceActor target source+  UpdMoveItem iid k aid c1 c2 -> Just $ UpdMoveItem iid k aid c2 c1+  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+  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+  UpdLeadFaction fid source target -> Just $ UpdLeadFaction fid target source+  UpdDiplFaction fid1 fid2 fromDipl toDipl ->+    Just $ UpdDiplFaction fid1 fid2 toDipl fromDipl+  UpdAutoFaction fid st -> Just $ UpdAutoFaction fid (not st)+  UpdRecordKill aid ikind k -> Just $ UpdRecordKill aid ikind (-k)+  UpdAlterTile lid p fromTile toTile ->+    Just $ UpdAlterTile lid p toTile fromTile+  UpdAlterClear lid delta -> Just $ UpdAlterClear lid (-delta)+  UpdSearchTile aid p fromTile toTile ->+    Just $ UpdSearchTile aid p toTile fromTile+  UpdLearnSecrets aid fromS toS -> Just $ UpdLearnSecrets aid toS fromS+  UpdSpotTile lid ts -> Just $ UpdLoseTile lid ts+  UpdLoseTile lid ts -> Just $ UpdSpotTile lid ts+  UpdAlterSmell lid p fromSm toSm -> Just $ UpdAlterSmell lid p toSm fromSm+  UpdSpotSmell lid sms -> Just $ UpdLoseSmell lid sms+  UpdLoseSmell lid sms -> Just $ UpdSpotSmell lid sms+  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+  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+  UpdResume{} -> Nothing+  UpdResumeServer{} -> Nothing+  UpdKillExit{} -> Nothing+  UpdSaveBkp -> Nothing+  UpdMsgAll{} -> Nothing  -- only generated by @cmdAtomicFilterCli@+  UpdRecordHistory{} -> Just cmd++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+  SfxProject aid iid -> SfxCatch aid iid+  SfxCatch aid iid -> SfxProject aid iid+  SfxActivate aid iid k -> SfxCheck aid iid k+  SfxCheck aid iid k -> SfxActivate aid iid k+  SfxTrigger aid p feat -> SfxShun aid p feat+  SfxShun aid p feat -> SfxTrigger aid p feat+  SfxEffect{} -> cmd  -- not ideal?+  SfxMsgFid{} -> cmd+  SfxMsgAll{} -> cmd+  SfxActorStart{} -> cmd++undoCmdAtomic :: CmdAtomic -> Maybe CmdAtomic+undoCmdAtomic (UpdAtomic cmd) = fmap UpdAtomic $ undoUpdAtomic cmd+undoCmdAtomic (SfxAtomic sfx) = Just $ SfxAtomic $ undoSfxAtomic sfx
+ Game/LambdaHack/Atomic/HandleAtomicWrite.hs view
@@ -0,0 +1,445 @@+-- | Semantics of atomic commands shared by client and server.+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Atomic.HandleAtomicWrite+  ( handleCmdAtomic+  ) where++import Control.Arrow (second)+import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+import Data.Int (Int64)+import Data.List+import Data.Maybe++import Game.LambdaHack.Atomic.CmdAtomic+import Game.LambdaHack.Atomic.MonadStateWrite+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.ModeKind as ModeKind+import Game.LambdaHack.Content.TileKind as TileKind++-- | The game-state semantics of atomic game commands.+-- Special effects (@SfxAtomic@) don't modify state.+handleCmdAtomic :: MonadStateWrite m => CmdAtomic -> m ()+handleCmdAtomic cmd = case cmd of+  UpdAtomic upd -> handleUpdAtomic upd+  SfxAtomic _ -> return ()++handleUpdAtomic :: MonadStateWrite m => UpdAtomic -> m ()+handleUpdAtomic cmd = case cmd of+  UpdCreateActor aid body ais -> updCreateActor aid body ais+  UpdDestroyActor aid body ais -> updDestroyActor aid body ais+  UpdCreateItem iid item k c -> updCreateItem iid item k c+  UpdDestroyItem iid item k c -> updDestroyItem iid item k c+  UpdSpotActor aid body ais -> updCreateActor aid body ais+  UpdLoseActor aid body ais -> updDestroyActor aid body ais+  UpdSpotItem iid item k c -> updCreateItem iid item k c+  UpdLoseItem iid item k c -> updDestroyItem iid item k c+  UpdMoveActor aid fromP toP -> updMoveActor aid fromP toP+  UpdWaitActor aid toWait -> updWaitActor aid toWait+  UpdDisplaceActor source target -> updDisplaceActor source target+  UpdMoveItem iid k aid c1 c2 -> updMoveItem iid k aid c1 c2+  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+  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+  UpdLeadFaction fid source target -> updLeadFaction fid source target+  UpdDiplFaction fid1 fid2 fromDipl toDipl ->+    updDiplFaction fid1 fid2 fromDipl toDipl+  UpdAutoFaction fid st -> updAutoFaction fid st+  UpdRecordKill aid ikind k -> updRecordKill aid ikind k+  UpdAlterTile lid p fromTile toTile -> updAlterTile lid p fromTile toTile+  UpdAlterClear lid delta -> updAlterClear lid delta+  UpdSearchTile _ _ fromTile toTile ->+    assert (fromTile /= toTile) $ return ()  -- only for clients+  UpdLearnSecrets aid fromS toS -> updLearnSecrets aid fromS toS+  UpdSpotTile lid ts -> updSpotTile lid ts+  UpdLoseTile lid ts -> updLoseTile lid ts+  UpdAlterSmell lid p fromSm toSm -> updAlterSmell lid p fromSm toSm+  UpdSpotSmell lid sms -> updSpotSmell lid sms+  UpdLoseSmell lid sms -> updLoseSmell lid sms+  UpdAgeGame t lids -> updAgeGame t lids+  UpdDiscover{} -> return ()      -- We can't keep dicovered data in State,+  UpdCover{} -> return ()         -- because server saves all atomic commands+  UpdDiscoverKind{} -> return ()  -- to apply their inverses for undo,+  UpdCoverKind{} -> return ()     -- so they would wipe out server knowledge.+  UpdDiscoverSeed{} -> return ()+  UpdCoverSeed{} -> return ()+  UpdPerception _ outPer inPer ->+    assert (not (nullPer outPer && nullPer inPer)) skip+  UpdRestart _ _ _ s _ _ -> updRestart s+  UpdRestartServer s -> updRestartServer s+  UpdResume{} -> return ()+  UpdResumeServer s -> updResumeServer s+  UpdKillExit{} -> return ()+  UpdSaveBkp -> return ()+  UpdMsgAll{} -> return ()+  UpdRecordHistory{} -> return ()++-- | Creates an actor. Note: after this command, usually a new leader+-- for the party should be elected (in case this actor is the only one alive).+updCreateActor :: MonadStateWrite m+               => ActorId -> Actor -> [(ItemId, Item)] -> m ()+updCreateActor aid body ais = do+  -- Add actor to @sactorD@.+  let f Nothing = Just body+      f (Just b) = assert `failure` "actor already added"+                          `twith` (aid, body, b)+  modifyState $ updateActorD $ EM.alter f aid+  -- Add actor to @sprio@.+  let g Nothing = Just [aid]+      g (Just l) = assert (aid `notElem` l `blame` "actor already added"+                                           `twith` (aid, body, l))+                   $ Just $ aid : l+  updateLevel (blid body) $ updatePrio $ EM.alter g (btime body)+  -- Actor's items may or may not be already present in @sitemD@,+  -- regardless if they are already present otherwise in the dungeon.+  -- We re-add them all to save time determining which really need it.+  forM_ ais $ \(iid, item) -> do+    let h item1 item2 =+          assert (item1 == item2 `blame` "inconsistent created actor items"+                                 `twith` (aid, body, iid, item1, item2)) item1+    modifyState $ updateItemD $ EM.insertWith h iid item++-- | Kills an actor.+updDestroyActor :: MonadStateWrite m+                => ActorId -> Actor -> [(ItemId, Item)] -> m ()+updDestroyActor aid body ais = do+  -- If a leader dies, a new leader should be elected on the server+  -- before this command is executed.+  -- TODO: check this only on the server (e.g., not in LoseActor):+  -- fact <- getsState $ (EM.! bfid body) . sfactionD+  -- assert (Just aid /= gleader fact `blame` (aid, body, fact)) skip+  -- Assert that actor's items belong to @sitemD@. Do not remove those+  -- that do not appear anywhere else, for simplicity and speed.+  itemD <- getsState sitemD+  let match (iid, item) = itemD EM.! iid == item+  assert (allB match ais `blame` "destroyed actor items not found"+                         `twith` (aid, body, ais, itemD)) skip+  -- 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"+                                     `twith` (aid, body, b)) Nothing+  modifyState $ updateActorD $ EM.alter f aid+  -- Remove actor from @sprio@.+  let g Nothing = assert `failure` "actor already removed" `twith` (aid, body)+      g (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+  updateLevel (blid body) $ updatePrio $ EM.alter g (btime body)++-- | Create a few copies of an item that is already registered for the dungeon+-- (in @sitemRev@ field of @StateServer@).+updCreateItem :: MonadStateWrite m+              => ItemId -> Item -> Int -> Container -> m ()+updCreateItem iid item k c = assert (k > 0) $ do+  -- The item may or may not be already present in @sitemD@,+  -- regardless if it's actually present in the dungeon.+  let f item1 item2 = assert (item1 == item2+                              `blame` "inconsistent created item"+                              `twith` (iid, item, k, c)) item1+  modifyState $ updateItemD $ EM.insertWith f iid item+  insertItemContainer iid k c++-- | Destroy some copies (possibly not all) of an item.+updDestroyItem :: MonadStateWrite m+               => ItemId -> Item -> Int -> Container -> m ()+updDestroyItem iid item 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 (iid `EM.lookup` itemD == Just item `blame` "item already removed"+                                             `twith` (iid, item, itemD)) skip+  deleteItemContainer iid k 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+  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+  updateActor aid $ \body -> body {bwait = toWait}++updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m ()+updDisplaceActor source target = assert (source /= target) $ do+  spos <- getsState $ bpos . getActorBody source+  tpos <- getsState $ bpos . getActorBody target+  updateActor source $ \b -> b {bpos = tpos, boldpos = spos}+  updateActor target $ \b -> b {bpos = spos, boldpos = tpos}++updMoveItem :: MonadStateWrite m+            => ItemId -> Int -> ActorId -> CStore -> CStore+            -> m ()+updMoveItem iid k aid c1 c2 = assert (k > 0 && c1 /= c2) $ do+  deleteItemActor iid k aid c1+  insertItemActor iid k aid c2++-- TODO: optimize (a single call to updatePrio is enough)+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++updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m ()+updRefillHP aid n =+  updateActor aid $ \b ->+    b { bhp = bhp b + n+      , bhpDelta = let oldD = bhpDelta b+                   in if n == 0+                      then ResDelta { resCurrentTurn = 0+                                    , resPreviousTurn = resCurrentTurn oldD }+                      else oldD {resCurrentTurn = resCurrentTurn oldD + n}+      }++updRefillCalm :: MonadStateWrite m => ActorId -> Int64 -> m ()+updRefillCalm aid n =+  updateActor aid $ \b ->+    b { bcalm = max 0 $ bcalm b + n+      , bcalmDelta = let oldD = bcalmDelta b+                     in if n == 0+                        then ResDelta { resCurrentTurn = 0+                                      , resPreviousTurn = resCurrentTurn oldD }+                        else oldD {resCurrentTurn = resCurrentTurn oldD + n}+      }++updOldFidActor :: MonadStateWrite m => ActorId -> FactionId -> FactionId -> m ()+updOldFidActor aid fromFid toFid = assert (fromFid /= toFid) $ do+  updateActor aid $ \b ->+    assert (boldfid b == fromFid `blame` (aid, fromFid, toFid, b))+    $ b {boldfid = toFid}++updTrajectory :: MonadStateWrite m+              => ActorId+              -> Maybe ([Vector], Speed)+              -> Maybe ([Vector], Speed)+              -> 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+  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+  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+  fact <- getsState $ (EM.! fid) . sfactionD+  assert (fromSt == gquit fact `blame` "unexpected actor quit status"+                               `twith` (fid, fromSt, toSt, fact)) skip+  let adj fa = fa {gquit = toSt}+  updateFaction fid adj++-- The previous leader is assumed to be alive.+updLeadFaction :: MonadStateWrite m+               => FactionId -> Maybe ActorId -> Maybe ActorId -> m ()+updLeadFaction fid source target = assert (source /= target) $ do+  fact <- getsState $ (EM.! fid) . sfactionD+  assert (playerLeader $ gplayer fact) skip  -- @PosNone@ ensure this+  mtb <- getsState $ \s -> fmap (flip getActorBody s) target+  assert (maybe True (not . bproj) mtb+          `blame` (fid, source, target, mtb, fact)) skip+  assert (source == gleader fact+          `blame` "unexpected actor leader"+          `twith` (fid, source, target, mtb, fact)) skip+  let adj fa = fa {gleader = target}+  updateFaction fid adj++updDiplFaction :: MonadStateWrite m+               => FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()+updDiplFaction fid1 fid2 fromDipl toDipl =+  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 adj fid fact = fact {gdipl = EM.insert fid toDipl (gdipl fact)}+    updateFaction fid1 (adj fid2)+    updateFaction fid2 (adj fid1)++updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m ()+updAutoFaction fid st = do+  let adj fact =+        let player = gplayer fact+        in assert (playerAI player == not st)+           $ fact {gplayer = player {playerAI = st}}+  updateFaction fid adj++-- | Record a given number (usually just 1, or -1 for undo) of actor kills+-- for score calculation.+updRecordKill :: MonadStateWrite m => ActorId -> Kind.Id ItemKind -> Int -> m ()+updRecordKill aid ikind k = do+  b <- getsState $ getActorBody aid+  assert (not (bproj b) `blame` (aid, b)) skip+  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++-- | Alter an attribute (actually, the only, the defining attribute)+-- of a visible tile. This is similar to e.g., @UpdTrajectory@.+updAlterTile :: MonadStateWrite m+             => LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind+             -> m ()+updAlterTile lid p fromTile toTile = assert (fromTile /= toTile) $ do+  Kind.COps{cotile} <- getsState scops+  lvl <- getLevel lid+  -- The second alternative below can happen if, e.g., a client remembers,+  -- but does not see the tile (so does not notice the SearchTile action),+  -- and it suddenly changes into another tile,+  -- which at the same time becomes visible (e.g., an open door).+  let adj ts = assert (ts PointArray.! p == fromTile+                       || ts PointArray.! p == Tile.hideAs cotile fromTile+                       `blame` "unexpected altered tile kind"+                       `twith` (lid, p, fromTile, toTile, ts PointArray.! p))+               $ ts PointArray.// [(p, toTile)]+  updateLevel lid $ updateTile adj+  case (Tile.isExplorable cotile fromTile, Tile.isExplorable cotile toTile) of+    (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl + 1}+    (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl - 1}+    _ -> return ()++updAlterClear :: MonadStateWrite m => LevelId -> Int -> m ()+updAlterClear lid delta = assert (delta /= 0) $+  updateLevel lid $ \lvl -> lvl {lclear = lclear lvl + delta}++-- TODO: use instead of revealing all secret positions initially, at once+-- in Common/State.hs.+updLearnSecrets :: MonadStateWrite m => ActorId -> Int -> Int -> m ()+updLearnSecrets aid fromS toS = assert (fromS /= toS) $ do+  b <- getsState $ getActorBody aid+  updateLevel (blid b) $ \lvl -> assert (lsecret lvl == fromS)+                                 $ lvl {lsecret = toS}++-- Notice previously invisible tiles. This is similar to @UpdSpotActor@,+-- but done in bulk, because it often involves dozens of tiles pers move.+-- We don't check that the tiles at the positions in question are unknown+-- to save computation, especially for clients that remember tiles+-- at previously seen positions. Similarly, when updating the @lseen@+-- field we don't assume the tiles were unknown previously.+updSpotTile :: MonadStateWrite m+            => LevelId -> [(Point, Kind.Id TileKind)] -> m ()+updSpotTile lid ts = assert (not $ null ts) $ do+  Kind.COps{cotile} <- getsState scops+  Level{ltile} <- getLevel lid+  let adj tileMap = tileMap PointArray.// ts+  updateLevel lid $ updateTile adj+  let f (p, t2) = do+        let t1 = ltile PointArray.! p+        case (Tile.isExplorable cotile t1, Tile.isExplorable cotile t2) of+          (False, True) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl+1}+          (True, False) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl-1}+          _ -> return ()+  mapM_ f ts++-- Stop noticing previously visible tiles. Unlike @updSpotActor@, it verifies+-- the state of the tiles before changing them.+updLoseTile :: MonadStateWrite m+            => LevelId -> [(Point, Kind.Id TileKind)] -> m ()+updLoseTile lid ts = assert (not $ null ts) $ do+  Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops+  let unknownId = ouniqGroup "unknown space"+      matches _ [] = True+      matches tileMap ((p, ov) : rest) =+        tileMap PointArray.! p == ov && matches tileMap rest+      tu = map (second (const unknownId)) ts+      adj tileMap = assert (matches tileMap ts) $ tileMap PointArray.// tu+  updateLevel lid $ updateTile adj+  let f (_, t1) =+        when (Tile.isExplorable cotile t1) $+          updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1}+  mapM_ f ts++updAlterSmell :: MonadStateWrite m+            => LevelId -> Point -> Maybe Time -> Maybe Time -> m ()+updAlterSmell lid p fromSm toSm = do+  let alt sm = assert (sm == fromSm `blame` "unexpected tile smell"+                                    `twith` (lid, p, fromSm, toSm, sm)) toSm+  updateLevel lid $ updateSmell $ EM.alter alt p++updSpotSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()+updSpotSmell lid sms = assert (not $ null sms) $ do+  let alt sm Nothing = Just sm+      alt sm (Just oldSm) = assert `failure` "smell already added"+                                   `twith` (lid, sms, sm, oldSm)+      f (p, sm) = EM.alter (alt sm) p+      upd m = foldr f m sms+  updateLevel lid $ updateSmell upd++updLoseSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()+updLoseSmell lid sms = assert (not $ null sms) $ do+  let alt sm Nothing = assert `failure` "smell already removed"+                              `twith` (lid, sms, sm)+      alt sm (Just oldSm) =+        assert (sm == oldSm `blame` "unexpected lost smell"+                            `twith` (lid, sms, sm, oldSm)) Nothing+      f (p, sm) = EM.alter (alt sm) p+      upd m = foldr f m sms+  updateLevel lid $ updateSmell upd++-- | Age the game.+--+-- TODO: It leaks information that there is activity on various level,+-- even if the faction has no actors there, so show this on UI somewhere,+-- e.g., in the @~@ menu of seen level indicate recent activity.+updAgeGame :: MonadStateWrite m => Delta Time -> [LevelId] -> m ()+updAgeGame delta lids = assert (delta /= Delta timeZero) $ do+  modifyState $ updateTime $ flip timeShift delta+  mapM_ (ageLevel delta) lids++ageLevel :: MonadStateWrite m => Delta Time -> LevelId -> m ()+ageLevel delta lid =+  updateLevel lid $ \lvl -> lvl {ltime = timeShift (ltime lvl) delta}++updRestart :: MonadStateWrite m+           => State -> m ()+updRestart = putState++updRestartServer :: MonadStateWrite m => State -> m ()+updRestartServer = putState++updResumeServer :: MonadStateWrite m => State -> m ()+updResumeServer = putState
+ Game/LambdaHack/Atomic/MonadAtomic.hs view
@@ -0,0 +1,31 @@+-- | Atomic monads.+module Game.LambdaHack.Atomic.MonadAtomic+  ( MonadAtomic(..)+  , broadcastUpdAtomic,  broadcastSfxAtomic+  ) where++import Data.Key (mapWithKeyM_)++import Game.LambdaHack.Atomic.CmdAtomic+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.State++class MonadStateRead m => MonadAtomic m where+  execAtomic    :: CmdAtomic -> m ()+  execUpdAtomic :: UpdAtomic -> m ()+  execUpdAtomic = execAtomic . UpdAtomic+  execSfxAtomic :: SfxAtomic -> m ()+  execSfxAtomic = execAtomic . SfxAtomic++broadcastUpdAtomic :: MonadAtomic m+                   => (FactionId -> UpdAtomic) -> m ()+broadcastUpdAtomic fcmd = do+  factionD <- getsState sfactionD+  mapWithKeyM_ (\fid _ -> execUpdAtomic $ fcmd fid) factionD++broadcastSfxAtomic :: MonadAtomic m+                   => (FactionId -> SfxAtomic) -> m ()+broadcastSfxAtomic fcmd = do+  factionD <- getsState sfactionD+  mapWithKeyM_ (\fid _ -> execSfxAtomic $ fcmd fid) factionD
+ Game/LambdaHack/Atomic/MonadStateWrite.hs view
@@ -0,0 +1,168 @@+-- | The monad for writing to the game state and related operations.+module Game.LambdaHack.Atomic.MonadStateWrite+  ( MonadStateWrite(..)+  , updateLevel, updateActor, updateFaction+  , insertItemContainer, insertItemActor, deleteItemContainer, deleteItemActor+  , updatePrio, updateFloor, updateTile, updateSmell+  ) where++import Control.Exception.Assert.Sugar+import qualified Data.EnumMap.Strict as EM++import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.State++class MonadStateRead m => MonadStateWrite m where+  modifyState :: (State -> State) -> m ()+  putState    :: State -> m ()++-- | Update the actor time priority queue.+updatePrio :: (ActorPrio -> ActorPrio) -> Level -> Level+updatePrio f lvl = lvl {lprio = f (lprio lvl)}++-- | Update the items on the ground map.+updateFloor :: (ItemFloor -> ItemFloor) -> Level -> Level+updateFloor f lvl = lvl {lfloor = f (lfloor lvl)}++-- | Update the tile map.+updateTile :: (TileMap -> TileMap) -> Level -> Level+updateTile f lvl = lvl {ltile = f (ltile lvl)}++-- | Update the smell map.+updateSmell :: (SmellMap -> SmellMap) -> Level -> Level+updateSmell f lvl = lvl {lsmell = f (lsmell lvl)}++-- | Update a given level data within state.+updateLevel :: MonadStateWrite m => LevelId -> (Level -> Level) -> m ()+updateLevel lid f = modifyState $ updateDungeon $ EM.adjust f lid++updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m ()+updateActor aid f = do+  let alt Nothing = assert `failure` "no body to update" `twith` aid+      alt (Just b) = Just $ f b+  modifyState $ updateActorD $ EM.alter alt aid++updateFaction :: MonadStateWrite m => FactionId -> (Faction -> Faction) -> m ()+updateFaction fid f = do+  let alt Nothing = assert `failure` "no faction to update" `twith` fid+      alt (Just fact) = Just $ f fact+  modifyState $ updateFactionD $ EM.alter alt fid++insertItemContainer :: MonadStateWrite m+                    => ItemId -> Int -> Container -> m ()+insertItemContainer iid k c = case c of+  CFloor lid pos -> insertItemFloor iid k lid pos+  CActor aid store -> insertItemActor iid k aid store+  CTrunk{} -> return ()++insertItemFloor :: MonadStateWrite m+                => ItemId -> Int -> LevelId -> Point -> m ()+insertItemFloor iid k lid pos =+  let bag = EM.singleton iid k+      mergeBag = EM.insertWith (EM.unionWith (+)) pos bag+  in updateLevel lid $ updateFloor mergeBag++insertItemActor :: MonadStateWrite m+                => ItemId -> Int -> ActorId -> CStore -> m ()+insertItemActor iid k aid cstore = case cstore of+  CGround -> do+    b <- getsState $ getActorBody aid+    insertItemFloor iid k (blid b) (bpos b)+  COrgan -> insertItemBody iid k aid+  CEqp -> insertItemEqp iid k aid+  CInv -> insertItemInv iid k aid+  CSha -> do+    b <- getsState $ getActorBody aid+    insertItemSha iid k (bfid b)++insertItemBody :: MonadStateWrite m+               => ItemId -> Int -> ActorId -> m ()+insertItemBody iid k aid = do+  let bag = EM.singleton iid k+      upd = EM.unionWith (+) bag+  updateActor aid $ \b -> b {borgan = upd (borgan b)}++insertItemEqp :: MonadStateWrite m+              => ItemId -> Int -> ActorId -> m ()+insertItemEqp iid k aid = do+  let bag = EM.singleton iid k+      upd = EM.unionWith (+) bag+  updateActor aid $ \b -> b {beqp = upd (beqp b)}++insertItemInv :: MonadStateWrite m+              => ItemId -> Int -> ActorId -> m ()+insertItemInv iid k aid = do+  let bag = EM.singleton iid k+      upd = EM.unionWith (+) bag+  updateActor aid $ \b -> b {binv = upd (binv b)}++insertItemSha :: MonadStateWrite m+               => ItemId -> Int -> FactionId -> m ()+insertItemSha iid k fid = do+  let bag = EM.singleton iid k+      upd = EM.unionWith (+) bag+  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+  CActor aid store -> deleteItemActor iid k aid store+  CTrunk{} -> return ()++deleteItemFloor :: MonadStateWrite m+                => ItemId -> Int -> LevelId -> Point -> m ()+deleteItemFloor iid k lid pos =+  let rmFromFloor (Just bag) =+        let nbag = rmFromBag k iid bag+        in if EM.null nbag then Nothing else Just nbag+      rmFromFloor Nothing = assert `failure` "item already removed"+                                   `twith` (iid, k, lid, pos)+  in updateLevel lid $ updateFloor $ EM.alter rmFromFloor pos++deleteItemActor :: MonadStateWrite m+                => ItemId -> Int -> ActorId -> CStore -> m ()+deleteItemActor iid k 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+  CSha -> do+    b <- getsState $ getActorBody aid+    deleteItemSha iid k (bfid b)++deleteItemBody :: MonadStateWrite m => ItemId -> Int -> ActorId -> m ()+deleteItemBody iid k aid = do+  updateActor aid $ \b -> b {borgan = rmFromBag k 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)}++deleteItemInv :: MonadStateWrite m => ItemId -> Int -> ActorId -> m ()+deleteItemInv iid k aid = do+  updateActor aid $ \b -> b {binv = rmFromBag k 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)}++rmFromBag :: Int -> ItemId -> ItemBag -> ItemBag+rmFromBag k iid bag =+  let rfb Nothing = assert `failure` "rm from empty slot" `twith` (k, iid, bag)+      rfb (Just n) =+        case compare n k of+          LT -> assert `failure` "rm more than there is"+                       `twith` (n, k, iid, bag)+          EQ -> Nothing+          GT -> Just (n - k)+  in EM.alter rfb iid bag
+ Game/LambdaHack/Atomic/PosAtomicRead.hs view
@@ -0,0 +1,329 @@+-- | Semantics of atomic commands shared by client and server.+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Atomic.PosAtomicRead+  ( PosAtomic(..), posUpdAtomic, posSfxAtomic+  , resetsFovCmdAtomic, breakUpdAtomic, breakSfxAtomic, loudUpdAtomic+  , seenAtomicCli, seenAtomicSer, generalMoveItem+  ) where++import Control.Applicative+import Control.Exception.Assert.Sugar+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Atomic.CmdAtomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.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.ModeKind as 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.+data PosAtomic =+    PosSight !LevelId ![Point]  -- ^ whomever sees all the positions, notices+  | PosFidAndSight !FactionId !LevelId ![Point]+                                -- ^ observers and the faction notice+  | PosSmell !LevelId ![Point]  -- ^ whomever smells all the positions, notices+  | PosFid !FactionId           -- ^ only the faction notices+  | PosFidAndSer !(Maybe LevelId) !FactionId  -- ^ faction and server notices+  | PosSer                      -- ^ only the server notices+  | PosAll                      -- ^ everybody notices+  | PosNone                     -- ^ never broadcasted, but sent manually+  deriving (Show, Eq)++-- | Produce the positions where the action takes place. If a faction+-- is returned, the action is visible only for that faction, if Nothing+-- is returned, it's never visible. Empty list of positions implies+-- the action is visible always.+--+-- 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+-- distinguishable by looking at the state (or the screen) from @UpdMoveActor@+-- of the illuminated actor, hence such @UpdDisplaceActor@ should not be+-- observable, but @UpdMoveActor@ should be (or the former should be perceived+-- as the latter). However, to simplify, we assing as strict visibility+-- requirements to @UpdMoveActor@ as to @UpdDisplaceActor@ and fall back+-- to @UpdSpotActor@ (which provides minimal information that does not+-- contradict state) if the visibility is lower.+posUpdAtomic :: MonadStateRead m => UpdAtomic -> m PosAtomic+posUpdAtomic cmd = case cmd of+  UpdCreateActor _ body _ -> posProjBody body+  UpdDestroyActor _ body _ -> posProjBody body+  UpdCreateItem _ _ _ c -> singleContainer c+  UpdDestroyItem _ _ _ c -> singleContainer c+  UpdSpotActor _ body _ -> posProjBody body+  UpdLoseActor _ body _ -> posProjBody body+  UpdSpotItem _ _ _ c -> singleContainer c+  UpdLoseItem _ _ _ c -> singleContainer c+  UpdMoveActor aid fromP toP -> do+    (lid, _) <- posOfAid aid+    return $! PosSight lid [fromP, toP]+  UpdWaitActor aid _ -> singleAid aid+  UpdDisplaceActor source target -> do+    (slid, sp) <- posOfAid source+    (tlid, tp) <- posOfAid target+    return $! assert (slid == tlid) $ PosSight slid [sp, tp]+  UpdMoveItem _ _ aid _ CSha -> do  -- shared stash is private+    b <- getsState $ getActorBody aid+    return $! PosFidAndSer (Just $ blid b) (bfid b)+  UpdMoveItem _ _ aid CSha _ -> do  -- shared stash is private+    b <- getsState $ getActorBody aid+    return $! PosFidAndSer (Just $ blid b) (bfid b)+  UpdMoveItem _ _ aid _ _ -> singleAid aid+  UpdAgeActor aid _ -> singleAid aid+  UpdRefillHP aid _ -> singleAid aid+  UpdRefillCalm aid _ -> singleAid aid+  UpdOldFidActor aid _ _ -> singleAid aid+  UpdTrajectory aid _ _ -> singleAid aid+  UpdColorActor aid _ _ -> singleAid aid+  UpdQuitFaction{} -> return PosAll+  UpdLeadFaction fid _ _ -> do+    fact <- getsState $ (EM.! fid) . sfactionD+    return $! if playerLeader $ gplayer fact+              then PosFidAndSer Nothing fid+              else PosNone+  UpdDiplFaction{} -> return PosAll+  UpdAutoFaction{} -> return PosAll+  UpdRecordKill aid _ _ -> singleFidAndAid aid+  UpdAlterTile lid p _ _ -> return $! PosSight lid [p]+  UpdAlterClear{} -> return PosAll+  UpdSearchTile aid p _ _ -> do+    (lid, pos) <- posOfAid aid+    return $! PosSight lid [pos, p]+  UpdLearnSecrets aid _ _ -> singleAid aid+  UpdSpotTile lid ts -> do+    let ps = map fst ts+    return $! PosSight lid ps+  UpdLoseTile lid ts -> do+    let ps = map fst ts+    return $! PosSight lid ps+  UpdAlterSmell lid p _ _ -> return $! PosSmell lid [p]+  UpdSpotSmell lid sms -> do+    let ps = map fst sms+    return $! PosSmell lid ps+  UpdLoseSmell lid sms -> do+    let ps = map fst sms+    return $! PosSmell lid ps+  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]+  UpdPerception{} -> return PosNone+  UpdRestart fid _ _ _ _ _ -> return $! PosFid fid+  UpdRestartServer _ -> return PosSer+  UpdResume fid _ -> return $! PosFid fid+  UpdResumeServer _ -> return PosSer+  UpdKillExit fid -> return $! PosFid fid+  UpdSaveBkp -> return PosAll+  UpdMsgAll{} -> return PosAll+  UpdRecordHistory fid -> return $! PosFid fid++-- | 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+    (slid, sp) <- posOfAid source+    (tlid, tp) <- posOfAid target+    return $! assert (slid == tlid) $ PosSight slid [sp, tp]+  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+  SfxTrigger aid p _ -> do+    (lid, pa) <- posOfAid aid+    return $! PosSight lid [pa, p]+  SfxShun aid p _ -> do+    (lid, pa) <- posOfAid aid+    return $! PosSight lid [pa, p]+  SfxEffect _ aid _ -> singleAid aid  -- sometimes we don't see source, OK+  SfxMsgFid fid _ -> return $! PosFid fid+  SfxMsgAll _ -> return PosAll+  SfxActorStart aid -> singleAid aid++posProjBody :: Monad m => Actor -> m PosAtomic+posProjBody body = return $!+  if bproj body+  then PosSight (blid body) [bpos body]+  else PosFidAndSight (bfid body) (blid body) [bpos body]++singleFidAndAid :: MonadStateRead m => ActorId -> m PosAtomic+singleFidAndAid aid = do+  body <- getsState $ getActorBody aid+  return $! PosFidAndSight (bfid body) (blid body) [bpos body]++singleAid :: MonadStateRead m => ActorId -> m PosAtomic+singleAid aid = do+  (lid, p) <- posOfAid aid+  return $! PosSight lid [p]++singleContainer :: MonadStateRead m => Container -> m PosAtomic+singleContainer (CFloor lid p) = return $! PosSight lid [p]+singleContainer (CActor aid CSha) = do  -- shared stash is private+  b <- getsState $ getActorBody aid+  return $! PosFidAndSer (Just $ blid b) (bfid b)+singleContainer (CActor aid _) = do+  (lid, p) <- posOfAid aid+  return $! PosSight lid [p]+singleContainer (CTrunk fid lid p) = return $! PosFidAndSight fid lid [p]++-- | Determines if a command resets FOV.+--+-- Invariant: if @resetsFovCmdAtomic@ determines we do not need+-- to reset Fov, perception (@ptotal@ to be precise, @psmell@ is irrelevant)+-- of any faction does not change upon recomputation. Otherwise,+-- save/restore would change game state.+resetsFovCmdAtomic :: UpdAtomic -> Bool+resetsFovCmdAtomic cmd = case cmd of+  -- Create/destroy actors and items.+  UpdCreateActor{} -> True  -- may have a light source+  UpdDestroyActor{} -> True+  UpdCreateItem{} -> True  -- may be a light source+  UpdDestroyItem{} -> True+  UpdSpotActor{} -> True+  UpdLoseActor{} -> True+  UpdSpotItem{} -> True+  UpdLoseItem{} -> True+  -- Move actors and items.+  UpdMoveActor{} -> True+  UpdDisplaceActor{} -> True+  UpdMoveItem{} -> True  -- light sources, sight radius bonuses+  UpdRefillCalm{} -> True  -- Calm caps sight radius+  -- Alter map.+  UpdAlterTile{} -> True  -- even if pos not visible initially+  UpdSpotTile{} -> True+  UpdLoseTile{} -> True+  _ -> False++-- | Decompose an atomic action. The original action is visible+-- if it's positions are visible both before and after the action+-- (in between the FOV might have changed). The decomposed actions+-- are only tested vs the FOV after the action and they give reduced+-- information that still modifies client's state to match the server state+-- wrt the current FOV and the subset of @posUpdAtomic@ that is visible.+-- The original actions give more information not only due to spanning+-- potentially more positions than those visible. E.g., @UpdMoveActor@+-- informs about the continued existence of the actor between+-- moves, v.s., popping out of existence and then back in.+breakUpdAtomic :: MonadStateRead m => UpdAtomic -> m [UpdAtomic]+breakUpdAtomic cmd = case cmd of+  UpdMoveActor aid _ toP -> do+    b <- getsState $ getActorBody aid+    ais <- getsState $ getCarriedAssocs b+    let loseSpot = [ UpdLoseActor aid b ais+                   , UpdSpotActor aid b {bpos = toP, boldpos = bpos b} ais ]+    fact <- getsState $ (EM.! bfid b) . sfactionD+    if gleader fact == Just aid+      then return $ [UpdLeadFaction (bfid b) (Just aid) Nothing]+                    ++ loseSpot+                    ++ [UpdLeadFaction (bfid b) Nothing (Just aid)]+      else return loseSpot+  UpdDisplaceActor source target -> do+    sb <- getsState $ getActorBody source+    sais <- getsState $ getCarriedAssocs sb+    tb <- getsState $ getActorBody target+    tais <- getsState $ getCarriedAssocs tb+    return [ UpdLoseActor source sb sais+           , UpdSpotActor source sb {bpos = bpos tb, boldpos = bpos sb} sais+           , UpdLoseActor target tb tais+           , UpdSpotActor target tb {bpos = bpos sb, boldpos = bpos tb} tais+           ]+  UpdMoveItem iid k aid cstore1 cstore2 | cstore1 == CSha  -- CSha is private+                                          || cstore2 == CSha -> do+    item <- getsState $ getItemBody iid+    return [ UpdLoseItem iid item k (CActor aid cstore1)+           , UpdSpotItem iid item k (CActor aid cstore2) ]+  -- No need to cover @UpdSearchTile@, because if an actor sees only+  -- one of the positions and so doesn't notice the search results,+  -- he's left with a hidden tile, which doesn't cause any trouble+  -- (because the commands doesn't change @State@ and the client-side+  -- processing of the command is lenient).+  _ -> return [cmd]++-- | Decompose an atomic special effect.+breakSfxAtomic :: MonadStateRead m => SfxAtomic -> m [SfxAtomic]+breakSfxAtomic cmd = case cmd of+  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 (Effect.RefillCalm (-1))+              | not $ bproj sb ]+              ++ [SfxEffect (bfid sb) target (Effect.RefillHP (-1))]+  _ -> return [cmd]++-- | Messages for some unseen game object creation/destruction/alteration.+loudUpdAtomic :: MonadStateRead m+              => Bool -> FactionId -> UpdAtomic -> m (Maybe Msg)+loudUpdAtomic local fid cmd = do+  msound <- case cmd of+    UpdDestroyActor _ body _+      -- Death of a party member does not need to be heard,+      -- because it's seen.+      | not $ fid == bfid body || bproj body -> return $ Just "shriek"+    UpdCreateItem{} -> return $ Just "clatter"+    UpdAlterTile _ _ fromTile _ -> do+      Kind.COps{cotile} <- getsState scops+      if Tile.isDoor cotile fromTile+        then return $ Just "creaking sound"+        else return $ Just "rumble"+    _ -> return Nothing+  let distant = if local then [] else ["distant"]+      hear sound = makeSentence [ "you hear"+                                , MU.AW $ MU.Phrase $ distant ++ [sound] ]+  return $! hear <$> msound++seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool+seenAtomicCli knowEvents fid per posAtomic =+  case posAtomic of+    PosSight _ ps -> all (`ES.member` totalVisible per) ps || knowEvents+    PosFidAndSight fid2 _ ps ->+      fid == fid2 || all (`ES.member` totalVisible per) ps || knowEvents+    PosSmell _ ps -> all (`ES.member` smellVisible per) ps || knowEvents+    PosFid fid2 -> fid == fid2+    PosFidAndSer _ fid2 -> fid == fid2+    PosSer -> False+    PosAll -> True+    PosNone -> assert `failure` "no position possible" `twith` fid++seenAtomicSer :: PosAtomic -> Bool+seenAtomicSer posAtomic =+  case posAtomic of+    PosFid _ -> False+    PosNone -> False+    _ -> True++generalMoveItem :: MonadStateRead m+                => ItemId -> Int -> Container -> Container+                -> m [UpdAtomic]+generalMoveItem iid k c1 c2 = do+  case (c1, c2) of+    (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2 -> do+      return [UpdMoveItem iid k aid1 cstore1 cstore2]+    _ -> do+      item <- getsState $ getItemBody iid+      return [ UpdLoseItem iid item k c1+             , UpdSpotItem iid item k c2 ]
Game/LambdaHack/Client.hs view
@@ -1,128 +1,46 @@ {-# LANGUAGE FlexibleContexts #-}--- | Semantics of client commands.+-- | Semantics of responses that are sent to clients.+-- -- See--- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Client-  ( cmdClientAISem, cmdClientUISem, exeFrontend-  , MonadClient, MonadClientUI, MonadClientReadServer, MonadClientWriteServer+  ( exeFrontend   ) where -import Control.Exception.Assert.Sugar-import Control.Monad-import Data.Maybe--import Game.LambdaHack.Client.Action-import Game.LambdaHack.Client.AtomicSemCli-import Game.LambdaHack.Client.Binding-import Game.LambdaHack.Client.ClientSem-import Game.LambdaHack.Client.Config-import Game.LambdaHack.Client.Draw-import Game.LambdaHack.Client.LoopAction+import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.LoopClient+import Game.LambdaHack.Client.ProtocolClient import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Animation (DebugModeCli (..))-import Game.LambdaHack.Common.AtomicCmd-import Game.LambdaHack.Common.ClientCmd+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.ServerCmd+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.Response import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Frontend -storeUndo :: MonadClient m => Atomic -> m ()-storeUndo _atomic =-  maybe skip (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli})-    $ Nothing   -- TODO: undoAtomic atomic--cmdClientAISem :: (MonadAtomic m, MonadClientWriteServer CmdTakeTimeSer m)-               => CmdClientAI -> m ()-cmdClientAISem cmd = case cmd of-  CmdAtomicAI cmdA -> do-    cmds <- cmdAtomicFilterCli cmdA-    mapM_ (\c -> cmdAtomicSemCli c-                 >> execCmdAtomic c) cmds-    mapM_ (storeUndo . CmdAtomic) cmds-  CmdQueryAI aid -> do-    cmdC <- queryAI aid-    writeServer cmdC-  CmdPingAI ->-    writeServer $ WaitSer $ toEnum (-1)--cmdClientUISem :: ( MonadAtomic m, MonadClientUI m-                  , MonadClientWriteServer CmdSer m )-               => CmdClientUI -> m ()-cmdClientUISem cmd = case cmd of-  CmdAtomicUI cmdA -> do-    cmds <- cmdAtomicFilterCli cmdA-    mapM_ (\c -> cmdAtomicSemCli c-                 >> execCmdAtomic c-                 >> drawCmdAtomicUI False c) cmds-    mapM_ (storeUndo . CmdAtomic) cmds  -- TODO: only store cmdA?-  SfxAtomicUI sfx -> do-    drawSfxAtomicUI False sfx-    storeUndo $ SfxAtomic sfx-  CmdQueryUI aid -> do-    mleader <- getsClient _sleader-    assert (isJust mleader `blame` "query without leader" `twith` cmd) skip-    cmdH <- queryUI aid-    writeServer cmdH-  CmdPingUI -> do-    -- Hack: in noMore mode, ping the frontend, too.-    snoMore <- getsClient $ snoMore . sdebugCli-    when snoMore $ void $ displayMore ColorFull "Flushing frames."-    -- Return the ping.-    writeServer $ CmdTakeTimeSer $ WaitSer $ toEnum (-1)- -- | Wire together game content, the main loop of game clients, -- the main game loop assigned to this frontend (possibly containing -- the server loop, if the whole game runs in one process), -- UI config and the definitions of game commands. exeFrontend :: ( MonadAtomic m, MonadClientUI m-               , MonadClientReadServer CmdClientUI m-               , MonadClientWriteServer CmdSer m+               , MonadClientReadResponse ResponseUI m+               , MonadClientWriteRequest RequestUI m                , MonadAtomic n-               , MonadClientReadServer CmdClientAI n-               , MonadClientWriteServer CmdTakeTimeSer n )+               , MonadClientReadResponse ResponseAI n+               , MonadClientWriteRequest RequestAI n )             => (m () -> SessionUI -> State -> StateClient-                -> ChanServer CmdClientUI CmdSer+                -> chanServerUI                 -> IO ())             -> (n () -> SessionUI -> State -> StateClient-                -> ChanServer CmdClientAI CmdTakeTimeSer+                -> chanServerAI                 -> IO ())-            -> Kind.COps -> DebugModeCli-            -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer-                 -> IO ())-               -> (FactionId -> ChanServer CmdClientAI CmdTakeTimeSer-                   -> IO ())+            -> KeyKind -> Kind.COps -> DebugModeCli+            -> ((FactionId -> chanServerUI -> IO ())+               -> (FactionId -> chanServerAI -> IO ())                -> IO ())             -> IO ()-exeFrontend executorUI executorAI-            cops@Kind.COps{corule} sdebugCli exeServer = do-  -- UI config reloaded at each client start.-  sconfigUI <- mkConfigUI corule-  let stdRuleset = Kind.stdRuleset corule-      !sbinding = stdBinding corule sconfigUI  -- evaluate to check for errors-      sdebugMode =-        (\dbg -> dbg {sfont =-            sfont dbg `mplus` Just (configFont sconfigUI)}) .-        (\dbg -> dbg {smaxFps =-            smaxFps dbg `mplus` Just (configMaxFps sconfigUI)}) .-        (\dbg -> dbg {snoAnim =-            snoAnim dbg `mplus` Just (configNoAnim sconfigUI)}) .-        (\dbg -> dbg {ssavePrefixCli =-            ssavePrefixCli dbg `mplus` Just (rsavePrefix stdRuleset)})-        $ sdebugCli-  defHist <- defHistory-  let exeClientUI = executorUI $ loopUI sdebugMode cmdClientUISem-      exeClientAI = executorAI $ loopAI sdebugMode cmdClientAISem-      cli = defStateClient defHist sconfigUI-      s = updateCOps (const cops) emptyState-      eClientAI fid =-        let noSession = assert `failure` "AI client needs no UI session"-                               `twith` fid-        in exeClientAI noSession s (cli fid True)-      eClientUI fid fromF =-        let sfconn = connFrontend fid fromF-        in exeClientUI SessionUI{..} s (cli fid False)-  startupF sdebugMode $ exeServer eClientUI eClientAI+exeFrontend executorUI executorAI copsClient cops sdebugCli exeServer =+  srtFrontend (executorUI . loopUI)+              (executorAI . loopAI)+              copsClient cops sdebugCli exeServer
+ Game/LambdaHack/Client/AI.hs view
@@ -0,0 +1,81 @@+-- | 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+    -- * Internal functions+  , refreshTarget, pickAction+  ) where++import Control.Exception.Assert.Sugar+import qualified Data.EnumMap.Strict as EM+import qualified Data.Text as T++import Game.LambdaHack.Client.AI.HandleAbilityClient+import Game.LambdaHack.Client.AI.PickActorClient+import Game.LambdaHack.Client.AI.PickTargetClient+import Game.LambdaHack.Client.AI.Strategy+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Request++-- | Handle the move of an AI player.+queryAI :: MonadClient m => ActorId -> m RequestAI+queryAI oldAid = do+  (aidToMove, bToMove) <- pickActorToMove refreshTarget oldAid+  RequestAnyAbility reqAny <- pickAction (aidToMove, bToMove)+  let req = ReqAITimed reqAny+  if aidToMove /= oldAid+    then return $! ReqAILeader aidToMove req+    else return $! req++-- | Client signals to the server that it's still online.+pongAI :: MonadClient m => m RequestAI+pongAI = return ReqAIPong++refreshTarget :: MonadClient m+              => ActorId -> (ActorId, Actor)+              -> m (Maybe ((ActorId, Actor), (Target, PathEtc)))+refreshTarget oldLeader (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+  tgtMPath <-+    if nullStrategy stratTarget then+      -- No sensible target; wipe out the old one.+      return Nothing+    else do+      -- Choose a target from those proposed by AI for the actor.+      tmp <- rndToAction $ frequency $ bestVariant stratTarget+      return $ Just tmp+  oldTgt <- getsClient $ EM.lookup aid . stargetD+  let _debug = T.unpack+          $ "\nHandleAI symbol:"    <+> tshow (bsymbol body)+          <> ", aid:"               <+> tshow aid+          <> ", pos:"               <+> tshow (bpos body)+          <> "\nHandleAI oldTgt:"   <+> tshow oldTgt+          <> "\nHandleAI strTgt:"   <+> tshow stratTarget+          <> "\nHandleAI target:"   <+> tshow tgtMPath+--  trace _debug skip+  modifyClient $ \cli ->+    cli {stargetD = EM.alter (const $ tgtMPath) aid (stargetD cli)}+  return $! case tgtMPath of+    Just (tgt, Just pathEtc) -> Just ((aid, body), (tgt, pathEtc))+    _ -> Nothing++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+  stratAction <- actionStrategy aid+  -- Run the AI: chose an action from those given by the AI strategy.+  rndToAction $ frequency $ bestVariant stratAction
+ Game/LambdaHack/Client/AI/ConditionClient.hs view
@@ -0,0 +1,262 @@+-- | Semantics of abilities in terms of actions and the AI procedure+-- for picking the best action for an actor.+module Game.LambdaHack.Client.AI.ConditionClient+  ( condTgtEnemyPresentM+  , condTgtEnemyRememberedM+  , condAnyFoeAdjM+  , condHpTooLowM+  , condOnTriggerableM+  , condBlocksFriendsM+  , condFloorWeaponM+  , condNoEqpWeaponM+  , condCanProjectM+  , condNotCalmEnoughM+  , condDesirableFloorItemM+  , condMeleeBadM+  , condLightBetraysM+  , benAvailableItems+  , benGroundItems+  , threatDistList+  , fleeList+  ) where++import Control.Applicative+import Control.Arrow ((&&&))+import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+import Data.List+import Data.Maybe+import Data.Ord++import Game.LambdaHack.Client.AI.Preferences+import Game.LambdaHack.Client.CommonClient+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Vector++-- | Require that the target enemy is visible by the party.+condTgtEnemyPresentM :: MonadClient m => ActorId -> m Bool+condTgtEnemyPresentM aid = do+  btarget <- getsClient $ getTarget aid+  return $! case btarget of+    Just TEnemy{} -> True+    _ -> False++-- | Require that the target enemy is remembered on the actor's level.+condTgtEnemyRememberedM :: MonadClient m => ActorId -> m Bool+condTgtEnemyRememberedM aid = do+  b <- getsState $ getActorBody aid+  btarget <- getsClient $ getTarget aid+  return $! case btarget of+    Just (TEnemyPos _ lid _ _) | lid == blid b -> True+    _ -> False++-- | Require that any non-dying foe is adjacent.+condAnyFoeAdjM :: MonadStateRead m => ActorId -> m Bool+condAnyFoeAdjM aid = do+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  allFoes <- getsState $ actorRegularList (isAtWar fact) (blid b)+  return $ any (adjacent (bpos b) . bpos) allFoes  -- keep it lazy++-- | Require the actor's HP is low enough.+condHpTooLowM :: MonadClient m => ActorId -> m Bool+condHpTooLowM aid = do+  b <- getsState $ getActorBody aid+  activeItems <- activeItemsClient aid+  return $! hpTooLow b activeItems++-- | Require the actor stands over a triggerable tile.+condOnTriggerableM :: MonadStateRead m => ActorId -> m Bool+condOnTriggerableM aid = do+  Kind.COps{cotile} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  let t = lvl `at` bpos b+  return $! not $ null $ Tile.causeEffects cotile t++-- | Produce the chess-distance-sorted list of non-low-HP foes on the level.+-- We don't consider path-distance, because we are interested in how soon+-- the foe can hit us, which can diverge greately from path distance+-- for short distances.+threatDistList :: MonadClient m => ActorId -> m [(Int, (ActorId, Actor))]+threatDistList aid = do+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  allAtWar <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)+  let strongActor (aid2, b2) = do+        activeItems <- activeItemsClient aid2+        return $! not $ hpTooLow b2 activeItems+  allThreats <- filterM strongActor allAtWar+  let addDist (aid2, b2) = (chessDist (bpos b) (bpos b2), (aid2, b2))+  return $ sortBy (comparing fst) $ map addDist allThreats++-- | Require the actor blocks the paths of any of his party members.+condBlocksFriendsM :: MonadClient m => ActorId -> m Bool+condBlocksFriendsM aid = do+  b <- getsState $ getActorBody aid+  ours <- getsState $ actorRegularAssocs (== bfid b) (blid b)+  targetD <- getsClient stargetD+  let blocked (aid2, _) = aid2 /= aid &&+        case EM.lookup aid2 targetD of+          Just (_, Just (_ : q : _, _)) | q == bpos b -> True+          _ -> False+  return $ any blocked ours  -- keep it lazy++-- | Require the actor stands over a weapon.+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 Effect.EqpSlotWeapon 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 Effect.EqpSlotWeapon allAssocs+    -- keep it lazy++-- | Require that the actor can project any items.+condCanProjectM :: MonadClient m => ActorId -> m Bool+condCanProjectM aid = do+  actorBlind <- radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight aid+  benList <- benAvailableItems aid permittedRanged [CEqp, CInv, CGround]+  let missiles = filter (maybe True ((< 0) . snd . snd) . fst . fst) benList+  return $ not actorBlind && not (null missiles)+    -- keep it lazy++-- | Produce the list of items with a given property available to the actor+-- and the items' values.+benAvailableItems :: MonadClient m+                  => ActorId -> (ItemFull -> Maybe Int -> Bool) -> [CStore]+                  -> m [( (Maybe (Int, (Int, Int)), (Int, CStore))+                        , (ItemId, ItemFull) )]+benAvailableItems aid permitted cstores = do+  cops <- getsState scops+  itemToF <- itemToFullClient+  b <- getsState $ getActorBody aid+  activeItems <- activeItemsClient aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  let ben cstore bag =+        [ ((benefit, (k, cstore)), (iid, itemFull))+        | (iid, k) <- EM.assocs bag+        , let itemFull = itemToF iid k+        , let benefit = totalUsefulness cops b activeItems fact itemFull+        , permitted itemFull (fst <$> benefit)]+      benCStore cs = do+        bag <- getsState $ getActorBag aid cs+        return $! ben cs bag+  perBag <- mapM benCStore cstores+  return $ concat perBag+    -- keep it lazy++-- | Require the actor is not calm enough.+condNotCalmEnoughM :: MonadClient m => ActorId -> m Bool+condNotCalmEnoughM aid = do+  b <- getsState $ getActorBody aid+  activeItems <- activeItemsClient aid+  return $! not (calmEnough b activeItems)++-- | Require that the actor stands over a desirable item.+condDesirableFloorItemM :: MonadClient m => ActorId -> m Bool+condDesirableFloorItemM aid = do+  benItemL <- benGroundItems aid+  return $ not $ null benItemL  -- keep it lazy++-- | Produce the list of items on the ground beneath the actor.+benGroundItems :: MonadClient m+               => ActorId+               -> m [( (Maybe (Int, (Int, Int))+                     , (Int, CStore)), (ItemId, ItemFull) )]+benGroundItems aid = do+  b <- getsState $ getActorBody aid+  fightsSpawners <- fightsAgainstSpawners (bfid b)+  let desirableItem ItemFull{itemBase} use+        | fightsSpawners = use /= Just 0+                           || Effect.Precious `elem` jfeature itemBase+        | otherwise = use /= Just 0+  benAvailableItems aid desirableItem [CGround]++-- | Require the actor is in a bad position to melee.+-- We do not check if the actor has a weapon, because having+-- no innate weapon is rare.+condMeleeBadM :: MonadClient m => ActorId -> m Bool+condMeleeBadM aid = do+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  condNoUsableWeapon <- null <$> pickWeaponClient aid aid+  let 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+      closeFriends = filter (closeEnough . snd) friends+      strongActor (aid2, b2) = do+        activeItems <- activeItemsClient aid2+        return $! not $ hpTooLow b2 activeItems+  strongCloseFriends <- filterM strongActor closeFriends+  let noFriendlyHelp = length closeFriends < 3 && null strongCloseFriends+  return $ condNoUsableWeapon+           || noFriendlyHelp  -- still not getting friends' help+    -- no $!; keep it lazy++-- | Require that the actor stands in the dark, but is betrayed+-- by his own equipped light,+condLightBetraysM :: MonadClient m => ActorId -> m Bool+condLightBetraysM aid = do+  b <- getsState $ getActorBody aid+  eqpItems <- map snd <$> fullAssocsClient aid [CEqp]+  let actorEqpShines = sumSlotNoFilter Effect.EqpSlotAddLight eqpItems > 0+  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+  cops <- getsState scops+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  let tgtPath = case mtgtMPath of  -- prefer fleeing along the path to target+        Just (_, Just (_ : path, _)) -> path+        _ -> []+  b <- getsState $ getActorBody aid+  fact <- getsState $ \s -> sfactionD s EM.! bfid b+  allFoes <- getsState $ actorRegularList (isAtWar fact) (blid b)+  lvl@Level{lxsize, lysize} <- getLevel $ blid b+  let posFoes = map bpos allFoes+      accessibleHere = accessible cops lvl $ bpos b+      myVic = vicinity lxsize lysize $ bpos b+      dist p | null posFoes = assert `failure` b+             | otherwise = minimum $ map (chessDist p) posFoes+      dVic = map (dist &&& id) myVic+      -- Flee, if possible. Access required.+      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
+ Game/LambdaHack/Client/AI/HandleAbilityClient.hs view
@@ -0,0 +1,803 @@+{-# LANGUAGE DataKinds #-}+-- | Semantics of abilities in terms of actions and the AI procedure+-- for picking the best action for an actor.+module Game.LambdaHack.Client.AI.HandleAbilityClient+  ( actionStrategy+  ) where++import Control.Applicative+import Control.Arrow (second)+import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Function+import Data.List+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Ord+import Data.Ratio+import Data.Text (Text)++import Game.LambdaHack.Client.AI.ConditionClient+import Game.LambdaHack.Client.AI.Preferences+import Game.LambdaHack.Client.AI.Strategy+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 qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Frequency+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.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 Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Content.TileKind as TileKind++type ToAny a = Strategy (RequestTimed a) -> Strategy RequestAnyAbility++toAny :: ToAny a+toAny strat = RequestAnyAbility <$> strat++-- | AI strategy based on actor's sight, smell, etc.+-- Never empty.+actionStrategy :: forall m. MonadClient m+               => ActorId -> m (Strategy RequestAnyAbility)+actionStrategy aid = do+  body <- getsState $ getActorBody aid+  activeItems <- activeItemsClient aid+  fact <- getsState $ (EM.! bfid body) . sfactionD+  condTgtEnemyPresent <- condTgtEnemyPresentM aid+  condTgtEnemyRemembered <- condTgtEnemyRememberedM aid+  condAnyFoeAdj <- condAnyFoeAdjM aid+  threatDistL <- threatDistList aid+  condHpTooLow <- condHpTooLowM aid+  condOnTriggerable <- condOnTriggerableM aid+  condBlocksFriends <- condBlocksFriendsM aid+  condNoEqpWeapon <- condNoEqpWeaponM aid+  condNoUsableWeapon <- null <$> pickWeaponClient aid aid+  condFloorWeapon <- condFloorWeaponM aid+  condCanProject <- condCanProjectM 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+      condThreatAtHand = not $ null $ takeWhile ((<= 2) . fst) threatDistL+      condThreatNearby = not $ null $ takeWhile ((<= nearby) . 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)+  mleader <- getsClient _sleader+  actorSk <- actorSkillsClient aid mleader+  let stratToFreq :: MonadStateRead m+                  => Int -> m (Strategy RequestAnyAbility)+                  -> m (Frequency RequestAnyAbility)+      stratToFreq scale mstrat = do+        st <- mstrat+        return $! scaleFreq scale $ bestVariant st  -- TODO: flatten instead?+      prefix, suffix :: [([Ability], m (Strategy RequestAnyAbility), Bool)]+      prefix =+        [ ( [AbApply], (toAny :: ToAny AbApply)+            <$> applyItem aid ApplyFirstAid+          , condHpTooLow && not condAnyFoeAdj+            && not condOnTriggerable )  -- don't block stairs, perhaps ascend+        , ( [AbTrigger], (toAny :: ToAny AbTrigger)+            <$> trigger aid True+              -- flee via stairs, even if to wrong level+              -- may return via different stairs+          , condOnTriggerable+            && ((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)+            <$> pickup aid True+          , condNoEqpWeapon && condFloorWeapon && not condHpTooLow )+        , ( [AbMelee], (toAny :: ToAny AbMelee)+            <$> meleeBlocker aid  -- only melee target or blocker+          , condAnyFoeAdj+            || EM.findWithDefault 0 AbDisplace actorSk <= 0+                 -- melee friends, not displace+               && not (playerLeader $ gplayer fact)  -- not restrained+               && (condTgtEnemyPresent || condTgtEnemyRemembered) )  -- excited+        , ( [AbTrigger], (toAny :: ToAny AbTrigger)+            <$> trigger aid False+          , condOnTriggerable && not condDesirableFloorItem )+        , ( [AbDisplace]  -- prevents some looping movement+          , displaceBlocker aid  -- fires up only when path blocked+          , not condDesirableFloorItem )+        , ( [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 ) ]+      distant :: [([Ability], m (Frequency RequestAnyAbility), Bool)]+      distant =+        [ ( [AbProject]  -- for high-value target, shoot even in melee+          , stratToFreq 2 $ (toAny :: ToAny AbProject)+            <$> ranged aid+          , condTgtEnemyPresent && condCanProject && not condOnTriggerable )+        , ( [AbApply]+          , stratToFreq 2 $ (toAny :: ToAny AbApply)+            <$> applyItem aid ApplyAll  -- use any option or scroll+          , (condTgtEnemyPresent || condThreatNearby)  -- can affect enemies+            && not condOnTriggerable )+        , ( [AbMove]+          , stratToFreq (if not condTgtEnemyPresent || condMeleeBad+                         then 1+                         else 100)+            $ chase aid True+          , (condTgtEnemyPresent || condTgtEnemyRemembered)+            && not condDesirableFloorItem+            && not condNoUsableWeapon ) ]+      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)+            <$> meleeAny aid  -- avoid getting damaged for naught+          , condAnyFoeAdj )+        , ( [AbMoveItem], (toAny :: ToAny AbMoveItem)+            <$> unEquipItems aid  -- late, because better to throw than unequip+          , True )+        , ( [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) )+        , ( [AbMove]+          , chase aid False+          , True )+        , ( [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 ) ]+      -- TODO: don't msum not to evaluate until needed+      abInSkill ab = EM.findWithDefault 0 ab actorSk > 0+      checkAction :: ([Ability], m a, Bool) -> Bool+      checkAction (abts, _, cond) = cond && all abInSkill abts+      sumS abAction = do+        let as = filter checkAction abAction+        strats <- sequence $ map (\(_, m, _) -> m) as+        return $! msum strats+      sumF abFreq = do+        let as = filter checkAction abFreq+        strats <- sequence $ map (\(_, m, _) -> m) as+        return $! msum strats+      combineDistant as = fmap liftFrequency $ sumF as+  sumPrefix <- sumS prefix+  comDistant <- combineDistant distant+  sumSuffix <- sumS suffix+  return $! sumPrefix .| comDistant .| sumSuffix++-- | A strategy to always just wait.+waitBlockNow :: MonadClient m => m (Strategy (RequestTimed AbWait))+waitBlockNow = return $! returN "wait" ReqWait++pickup :: MonadClient m+       => ActorId -> Bool -> m (Strategy (RequestTimed AbMoveItem))+pickup aid onlyWeapon = do+  benItemL <- benGroundItems aid+  let isWeapon (_, (_, itemFull)) =+        maybe False ((== Effect.EqpSlotWeapon) . fst)+        $ strengthEqpSlot $ itemBase 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+      updateItemSlot (Just aid) iid+      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++equipItems :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMoveItem))+equipItems aid = do+  cops@Kind.COps{corule} <- getsState scops+  let RuleKind{rsharedStash} = Kind.stdRuleset corule+  body <- getsState $ getActorBody aid+  activeItems <- activeItemsClient aid+  fact <- getsState $ (EM.! bfid body) . sfactionD+  eqpAssocs <- fullAssocsClient aid [CEqp]+  invAssocs <- fullAssocsClient aid [CInv]+  shaAssocs <- fullAssocsClient aid [CSha]+  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+      -- 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+      bestThree = bestByEqpSlot (filter filterNeeded invAssocs)+                                (filter filterNeeded eqpAssocs)+                                (filter filterNeeded shaAssocs)+      bEqpInv = msum $ map (improve CInv)+                $ map (\(_, (eqp, inv, _)) -> (inv, eqp)) bestThree+  if nullStrategy bEqpInv+    then if rsharedStash && calmEnough body activeItems+         then return+              $! msum $ map (improve CSha)+              $ map (\(_, (eqp, _, sha)) -> (sha, eqp)) bestThree+         else return reject+    else return bEqpInv++unEquipItems :: MonadClient m+             => ActorId -> m (Strategy (RequestTimed AbMoveItem))+unEquipItems aid = do+  cops@Kind.COps{corule} <- getsState scops+  let RuleKind{rsharedStash} = Kind.stdRuleset corule+  body <- getsState $ getActorBody aid+  activeItems <- activeItemsClient aid+  fact <- getsState $ (EM.! bfid body) . sfactionD+  eqpAssocs <- fullAssocsClient aid [CEqp]+  invAssocs <- fullAssocsClient aid [CInv]+  shaAssocs <- fullAssocsClient aid [CSha]+  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 -> ( Effect.EqpSlot+                           , ( [(Int, (ItemId, ItemFull))]+                             , [(Int, (ItemId, ItemFull))] ) )+              -> Strategy (RequestTimed AbMoveItem)+      improve fromCStore (slot, (bestInv, bestEqp)) =+        case (bestInv, bestEqp) of+          _ | slot == Effect.EqpSlotPeriodic+              && 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 ->+            -- 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 ->+            -- To share the second best items with others, if they care.+            returN "yield worse"+            $ ReqMoveItem iidEqp (getK bestEqp) fromCStore CSha+          _ -> reject+      getK [] = 0+      getK ((_, (_, itemFull)) : _) = itemK itemFull+      betterThanInv _ [] = True+      betterThanInv vEqp ((vInv, _) : _) = vEqp > vInv+      bestThree = bestByEqpSlot invAssocs eqpAssocs shaAssocs+  case yieldUnneeded of+    [] ->+      if rsharedStash && calmEnough body activeItems+      then do+        let bInvSha = msum $ map (improve CInv)+                      $ map (\((slot, _), (_, inv, sha)) ->+                               (slot, (sha, inv))) bestThree+        if nullStrategy bInvSha+          then return $! msum $ map (improve CEqp)+                         $ map (\((slot, _), (eqp, _, sha)) ->+                                 (slot, (sha, eqp))) bestThree+          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++groupByEqpSlot :: [(ItemId, ItemFull)]+               -> M.Map (Effect.EqpSlot, Text) [(ItemId, ItemFull)]+groupByEqpSlot is =+  let f (iid, itemFull) = case strengthEqpSlot $ itemBase itemFull of+        Nothing -> Nothing+        Just es -> Just (es, [(iid, itemFull)])+      withES = mapMaybe f is+  in M.fromListWith (++) withES++bestByEqpSlot :: [(ItemId, ItemFull)]+              -> [(ItemId, ItemFull)]+              -> [(ItemId, ItemFull)]+              -> [((Effect.EqpSlot, Text)+                  , ( [(Int, (ItemId, ItemFull))]+                    , [(Int, (ItemId, ItemFull))]+                    , [(Int, (ItemId, ItemFull))] ) )]+bestByEqpSlot invAssocs eqpAssocs shaAssocs =+  let eqpMap = M.map (\g -> (g, [], [])) $ groupByEqpSlot eqpAssocs+      invMap = M.map (\g -> ([], g, [])) $ groupByEqpSlot invAssocs+      shaMap = M.map (\g -> ([], [], g)) $ groupByEqpSlot shaAssocs+      appendThree (g1, g2, g3) (h1, h2, h3) = (g1 ++ h1, g2 ++ h2, g3 ++ h3)+      invEqpShaMap = M.unionsWith appendThree [invMap, eqpMap, shaMap]+      bestSingle eqpSlot g = strongestSlot eqpSlot g+      bestThree (eqpSlot, _) (g1, g2, g3) = (bestSingle eqpSlot g1,+                                             bestSingle eqpSlot g2,+                                             bestSingle eqpSlot g3)+  in M.assocs $ M.mapWithKey bestThree invEqpShaMap++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 Effect.EqpSlotAddLight itemFull)+       || 0 > fromMaybe 0 (strengthFromEqpSlot Effect.EqpSlotAddHurtMelee+                                               itemFull)+       || 0 > fromMaybe 0 (strengthFromEqpSlot Effect.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 Effect.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+  -- should not be equipped (either they are harmful or they waste eqp space).+  maybe False (\(u, _) -> u <= 0)+    (totalUsefulness cops body activeItems fact itemFull)+  && (maybe True ((/= Effect.EqpSlotWeapon) . fst)+      $ strengthEqpSlot $ itemBase itemFull)++unneeded :: Kind.COps -> Bool -> Actor -> [ItemFull] -> Faction -> ItemFull+         -> Bool+unneeded cops condLightBetrays body activeItems fact itemFull =+  harmful cops body activeItems fact itemFull+  || hinders condLightBetrays body activeItems itemFull++-- Everybody melees in a pinch, even though some prefer ranged attacks.+meleeBlocker :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMelee))+meleeBlocker aid = do+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  mleader <- getsClient _sleader+  actorSk <- actorSkillsClient aid mleader+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  case mtgtMPath of+    Just (_, Just (_ : q : _, (goal, _))) -> do+      -- We prefer the goal (e.g., when no accessible, but adjacent),+      -- but accept @q@ even if it's only a blocking enemy position.+      let maim = if adjacent (bpos b) goal then Just goal+                 else if adjacent (bpos b) q then Just q+                 else Nothing  -- MeleeDistant+      mBlocker <- case maim of+        Nothing -> return Nothing+        Just aim -> getsState $ posToActor aim (blid b)+      case mBlocker of+        Just ((aid2, _), _) -> do+          -- No problem if there are many projectiles at the spot. We just+          -- attack the first one.+          body2 <- getsState $ getActorBody aid2+          if not (actorDying body2)  -- already dying+             && (not (bproj body2)  -- displacing saves a move+                 && isAtWar fact (bfid body2)  -- they at war with us+                 || EM.findWithDefault 0 AbDisplace actorSk <= 0  -- not disp.+                    && not (playerLeader $ gplayer fact)  -- not restrained+                    && EM.findWithDefault 0 AbMove actorSk > 0  -- blocked move+                    && bhp body2 < bhp b)  -- respect power+            then do+              mel <- pickWeaponClient aid aid2+              return $! liftFrequency $ uniformFreq "melee in the way" mel+            else return reject+        Nothing -> return reject+    _ -> return reject  -- probably no path to the enemy, if any++-- Everybody melees in a pinch, skills and weapons allowing,+-- even though some prefer ranged attacks.+meleeAny :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMelee))+meleeAny aid = do+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)+  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+  return $! liftFrequency freq++-- Fast monsters don't pay enough attention to features.+trigger :: MonadClient m+        => ActorId -> Bool -> m (Strategy (RequestTimed AbTrigger))+trigger aid fleeViaStairs = do+  cops@Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops+  dungeon <- getsState sdungeon+  explored <- getsClient sexplored+  b <- getsState $ getActorBody aid+  activeItems <- activeItemsClient aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  lvl <- getLevel $ blid b+  unexploredD <- unexploredDepth+  s <- getState+  per <- getPerFid $ blid b+  let canSee = ES.member (bpos b) (totalVisible per)+      unexploredCurrent = ES.notMember (blid b) explored+      allExplored = ES.size explored == EM.size dungeon+      t = lvl `at` bpos b+      feats = TileKind.tfeature $ okind t+      ben feat = case feat of+        F.Cause (Effect.Ascend k) ->  -- change levels sensibly, in teams+          let expBenefit =+                if not (playerLeader (gplayer fact))+                then 100  -- not-exploring faction, switch at will+                else if unexploredCurrent+                then 0  -- don't leave the level until explored+                else if unexploredD (signum k) (blid b)+                then 1000+                else if unexploredD (- signum k) (blid b)+                then 0  -- wait for stairs in the opposite direciton+                else if lescape lvl+                then 0  -- all explored, stay on the escape level+                else 2  -- no escape anywhere, switch levels occasionally+              (lid2, pos2) = whereTo (blid b) (bpos b) k dungeon+              actorsThere = posToActors pos2 lid2 s+              leaderless = not $ playerLeader $ gplayer fact+          in if boldpos b == bpos b   -- probably used stairs last turn+                && boldlid b == lid2  -- in the opposite direction+             then 0  -- avoid trivial loops (pushing, being pushed, etc.)+             else 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+        F.Cause ef@Effect.Escape{} -> do  -- flee via this way, too+          -- Only some factions try to escape but they first explore all+          -- for high score.+          if not (keepArenaFact fact) || not allExplored+          then 0+          else effectToBenefit cops b activeItems fact ef+        F.Cause ef | not fleeViaStairs ->+          effectToBenefit cops b activeItems fact ef+        _ -> 0+      benFeat = zip (map ben feats) feats+  return $! liftFrequency $ toFreq "trigger"+         $ [ (benefit, ReqTrigger (Just feat))+           | (benefit, feat) <- benFeat+           , benefit > 0 ]++ranged :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbProject))+ranged aid = do+  btarget <- getsClient $ getTarget aid+  b@Actor{bpos, blid} <- getsState $ getActorBody aid+  mfpos <- aidTgtToPos aid blid btarget+  seps <- getsClient seps+  case (btarget, mfpos) of+    (Just TEnemy{}, Just fpos) -> do+      actorBlind <- radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight aid+      mnewEps <- makeLine b fpos seps+      case mnewEps of+        Just newEps | not actorBlind -> do  -- ProjectBlind+          -- ProjectAimOnself, ProjectBlockActor, ProjectBlockTerrain+          -- and no actors or obstracles along the path.+          benList <- benAvailableItems aid permittedRanged [CEqp, CInv, CGround]+          let coeff CGround = 2+              coeff COrgan = 3  -- can't give to others+              coeff CEqp = 1+              coeff CInv = 1+              coeff CSha = undefined  -- banned+              fRanged ((mben, (_, cstore)), (iid, ItemFull{itemBase})) =+                let trange = totalRange itemBase+                    bestRange = chessDist bpos fpos + 2  -- margin for fleeing+                    rangeMult =  -- penalize wasted or unsafely low range+                      10 + max 0 (10 - abs (trange - bestRange))+                    durableBonus = if Effect.Durable `elem` jfeature itemBase+                                   then 2  -- we or foes keep it after the throw+                                   else 1+                    benR = durableBonus+                           * coeff cstore+                           * case mben of+                               Nothing -> -20  -- experimenting is fun+                               Just (_, (_, ben)) -> ben+                in if benR < 0 && trange >= chessDist bpos fpos+                   then Just ( -benR * rangeMult `div` 10+                             , ReqProject fpos newEps iid cstore )+                   else Nothing+              benRanged = mapMaybe fRanged benList+          return $! liftFrequency $ toFreq "ranged" benRanged+        _ -> return reject+    _ -> return reject++data ApplyItemGroup = ApplyAll | ApplyFirstAid+  deriving Eq++applyItem :: MonadClient m+          => ActorId -> ApplyItemGroup -> m (Strategy (RequestTimed AbApply))+applyItem aid applyGroup = do+  actorBlind <- radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight aid+  let permitted itemFull@ItemFull{itemBase=item} _ =+        not (unknownPrecious itemFull)+        && if jsymbol item == '?' && actorBlind+           then False+           else Effect.Applicable `elem` jfeature item+  benList <- benAvailableItems aid permitted [CEqp, CInv, CGround]+  let itemLegal itemFull = case applyGroup of+        ApplyFirstAid ->+          let getP (Effect.RefillHP p) _ | p > 0 = True+              getP _ acc = acc+          in case itemDisco itemFull of+            Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->+              foldr getP False jeffects+            _ -> False+        ApplyAll -> True+      coeff CGround = 2+      coeff COrgan = 3  -- can't give to others+      coeff CEqp = 1+      coeff CInv = 1+      coeff CSha = undefined  -- banned+      fTool ((mben, (_, cstore)), (iid, itemFull)) =+        let durableBonus = if Effect.Durable `elem` jfeature (itemBase itemFull)+                           then 5  -- we keep it after use+                           else 1+            benR = durableBonus+                   * coeff cstore+                   * case mben of+                       Nothing -> 0+                         -- experimenting is fun, but it's better to risk+                         -- foes' skin than ours -- TODO: when {activated}+                         -- is implemented, enable this for items too heavy,+                         -- etc. for throwing+                       Just (_, (_, ben)) -> ben+        in if itemLegal itemFull+           then if benR > 0+                then Just (benR, ReqApply iid cstore)+                else Nothing+           else Nothing+      benTool = mapMaybe fTool benList+  return $! liftFrequency $ toFreq "applyItem" benTool++-- If low on health or alone, flee in panic, close to the path to target+-- and as far from the attackers, as possible. Usually fleeing from+-- foes will lead towards friends, but we don't insist on that.+-- We use chess distances, not pathfinding, because melee can happen+-- at path distance 2.+flee :: MonadClient m+     => ActorId -> [(Int, Point)] -> m (Strategy RequestAnyAbility)+flee aid fleeL = do+  b <- getsState $ getActorBody aid+  let vVic = map (second (`vectorToFrom` bpos b)) fleeL+      str = liftFrequency $ toFreq "flee" vVic+  mapStrategyM (moveOrRunAid True aid) str++displaceFoe :: MonadClient m => ActorId -> m (Strategy RequestAnyAbility)+displaceFoe aid = do+  cops <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  fact <- getsState $ (EM.! bfid b) . sfactionD+  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)+      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+        let nFr = nFriends body2+        return $! if displaceable body2 && dEnemy && nFr < nFrHere+          then Just (nFr * nFr, bpos body2 `vectorToFrom` bpos b)+          else Nothing+  vFoes <- mapM qualifyActor allFoes+  let str = liftFrequency $ toFreq "displaceFoe" $ catMaybes vFoes+  mapStrategyM (moveOrRunAid True aid) str++displaceBlocker :: MonadClient m => ActorId -> m (Strategy RequestAnyAbility)+displaceBlocker aid = do+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  str <- case mtgtMPath of+    Just (_, Just (p : q : _, _)) -> displaceTowards aid p q+    _ -> return reject  -- goal reached+  mapStrategyM (moveOrRunAid True aid) str++-- TODO: perhaps modify target when actually moving, not when+-- producing the strategy, even if it's a unique choice in this case.+displaceTowards :: MonadClient m+                => ActorId -> Point -> Point -> m (Strategy Vector)+displaceTowards aid source target = do+  cops <- getsState scops+  b <- getsState $ getActorBody aid+  assert (source == bpos b && adjacent source target) skip+  lvl <- getLevel $ blid b+  if boldpos b /= target -- avoid trivial loops+     && accessible cops lvl source target then do  -- DisplaceAccess+    mBlocker <- getsState $ posToActors target (blid b)+    case mBlocker of+      [] -> return reject+      [((aid2, b2), _)] -> do+        mtgtMPath <- getsClient $ EM.lookup aid2 . stargetD+        case mtgtMPath of+          Just (tgt, Just (p : q : rest, (goal, len)))+            | q == source && p == target -> do+              let newTgt = Just (tgt, Just (q : rest, (goal, len - 1)))+              modifyClient $ \cli ->+                cli {stargetD = EM.alter (const $ newTgt) aid (stargetD cli)}+              return $! returN "displace friend" $ target `vectorToFrom` source+          Just _ -> return reject+          Nothing -> do+            tfact <- getsState $ (EM.! bfid b2) . sfactionD+            activeItems <- activeItemsClient aid2+            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+      _ -> return reject  -- DisplaceProjectiles+  else return reject++chase :: MonadClient m => ActorId -> Bool -> m (Strategy RequestAnyAbility)+chase aid doDisplace = do+  body <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid body) . sfactionD+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  str <- case mtgtMPath of+    Just (_, Just (p : q : _, (goal, _))) ->+      -- With no leader, the goal is vague, so permit arbitrary detours.+      moveTowards aid p q goal (not $ playerLeader (gplayer fact))+    _ -> return reject  -- goal reached+  -- If @doDisplace@: don't pick fights, assuming the target is more important.+  -- We'd normally melee the target earlier on via @AbMelee@, but for+  -- actors that don't have this ability (and so melee only when forced to),+  -- this is meaningul.+  mapStrategyM (moveOrRunAid doDisplace aid) str++moveTowards :: MonadClient m+            => ActorId -> Point -> Point -> Point -> Bool -> m (Strategy Vector)+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+  lvl <- getLevel $ blid b+  fact <- getsState $ (EM.! bfid b) . sfactionD+  friends <- getsState $ actorList (not . isAtWar fact) $ blid b+  let noFriends = unoccupied friends+      accessibleHere = accessible cops lvl source+      bumpableHere p =+        let t = lvl `at` p+        in Tile.isOpenable cotile t+           || Tile.isSuspect cotile t+           || Tile.isChangeable cotile t+      enterableHere p = accessibleHere p || bumpableHere p+  if noFriends target && enterableHere target then+    return $! returN "moveTowards adjacent" $ target `vectorToFrom` source+  else do+    let goesBack v = v == boldpos b `vectorToFrom` source+        nonincreasing p = chessDist source goal >= chessDist p goal+        isSensible p = (relaxed || nonincreasing p)+                       && noFriends p+                       && enterableHere p+        sensible = [ ((goesBack v, chessDist p goal), v)+                   | v <- moves, let p = source `shift` v, isSensible p ]+        sorted = sortBy (comparing fst) sensible+        groups = map (map snd) $ groupBy ((==) `on` fst) sorted+        freqs = map (liftFrequency . uniformFreq "moveTowards") groups+    return $! foldr (.|) reject freqs++-- | Actor moves or searches or alters or attacks. Displaces if @run@.+-- This function is very general, even though it's often used in contexts+-- when only one or two of the many cases can possibly occur.+moveOrRunAid :: MonadClient m+             => Bool -> ActorId -> Vector -> m (Maybe RequestAnyAbility)+moveOrRunAid run 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+  -- We start by checking actors at the the target position,+  -- which gives a partial information (actors can be invisible),+  -- as opposed to accessibility (and items) which are always accurate+  -- (tiles can't be invisible).+  tgts <- getsState $ posToActors tpos lid+  case tgts of+    [((target, b2), _)] | run ->  do -- can be a foe, as well as a friend+      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 cannot displace, hit. TODO: unless melee or wait not permitted.+        wps <- pickWeaponClient source target+        case wps of+          [] -> return Nothing+          wp : _ -> return $! Just $ RequestAnyAbility wp+    ((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+      if accessible cops lvl spos tpos then+        -- Movement requires full access.+        return $! Just $ RequestAnyAbility $ ReqMove dir+        -- The potential invisible actor is hit.+      else if not $ EM.null $ lvl `atI` tpos then+        -- This is, e.g., inaccessible open door with an item in it.+        assert `failure` "AI causes AlterBlockItem" `twith` (run, source, dir)+      else if not (Tile.isWalkable cotile t)  -- not implied+              && (Tile.isSuspect cotile t+                  || Tile.isOpenable cotile t+                  || Tile.isClosable cotile t+                  || Tile.isChangeable cotile t) then+        -- No access, so search and/or alter the tile.+        return $! Just $ RequestAnyAbility $ ReqAlter tpos Nothing+      else+        -- Boring tile, no point bumping into it, do WaitSer if really idle.+        assert `failure` "AI causes MoveNothing or AlterNothing"+               `twith` (run, source, dir)
+ Game/LambdaHack/Client/AI/PickActorClient.hs view
@@ -0,0 +1,197 @@+-- | Semantics of most 'ResponseAI' client commands.+module Game.LambdaHack.Client.AI.PickActorClient+  ( pickActorToMove+  ) where++import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+import Data.List+import Data.Maybe+import Data.Ord++import Game.LambdaHack.Client.AI.ConditionClient+import Game.LambdaHack.Client.CommonClient+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Frequency+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Vector++pickActorToMove :: MonadClient m+                => (ActorId -> (ActorId, Actor)+                    -> m (Maybe ((ActorId, Actor), (Target, PathEtc))))+                -> ActorId+                -> m (ActorId, Actor)+pickActorToMove refreshTarget oldAid = do+  cops@Kind.COps{cotile} <- getsState scops+  oldBody <- getsState $ getActorBody oldAid+  let side = bfid oldBody+      arena = blid oldBody+  fact <- getsState $ (EM.! side) . sfactionD+  lvl <- getLevel arena+  let leaderStuck = waitedLastTurn oldBody+      t = lvl `at` bpos oldBody+  mleader <- getsClient _sleader+  ours <- getsState $ actorRegularAssocs (== side) arena+  let pickOld = do+        void $ refreshTarget oldAid (oldAid, oldBody)+        return (oldAid, oldBody)+  case ours of+    _ | -- Keep the leader: only a leader is allowed to pick another leader.+        mleader /= Just oldAid+        -- Keep the leader: all can move. TODO: check not accurate,+        -- instead define 'movesThisTurn' and use elsehwere.+        || isAllMoveFact cops fact+        -- Keep the leader: he is on stairs and not stuck+        -- and we don't want to clog stairs or get pushed to another level.+        || not leaderStuck && Tile.isStair cotile t+      -> pickOld+    [] -> assert `failure` (oldAid, oldBody)+    [_] -> pickOld  -- Keep the leader: he is alone on the level.+    (captain, captainBody) : (sergeant, sergeantBody) : _ -> do+      -- At this point we almost forget who the old leader was+      -- and treat all party actors the same, eliminating candidates+      -- until we can't distinguish them any more, at which point we prefer+      -- the old leader, if he is among the best candidates+      -- (to make the AI appear more human-like 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+            activeItems <- activeItemsClient aid+            condMeleeBad <- condMeleeBadM aid+            threatDistL <- threatDistList aid+            fleeL <- fleeList False aid+            let condThreatAdj =+                  not $ null $ takeWhile ((== 1) . fst) threatDistL+                condFastThreatAdj =+                  any (\(_, (_, b)) ->+                         bspeed b activeItems > bspeed body activeItems)+                  $ takeWhile ((== 1) . fst) threatDistL+                condCanFlee = not (null fleeL || condFastThreatAdj)+                heavilyDistressed =+                  -- Actor hit by a projectile or similarly distressed.+                  deltaSerious (bcalmDelta body)+            return $! if condThreatAdj+                      then condMeleeBad && condCanFlee+                      else heavilyDistressed+                        -- TODO: modify when reaction fire is possible+          actorHearning (_, (TEnemyPos{}, (_, (_, d)))) | d <= 2 =+            return False  -- noise probably due to fleeing target+          actorHearning ((_aid, b), _) = do+            allFoes <- getsState $ actorRegularList (isAtWar fact) (blid b)+            let closeFoes = filter ((<= 3) . chessDist (bpos b) . bpos) allFoes+                mildlyDistressed = deltaMild (bcalmDelta b)+            return $! mildlyDistressed  -- e.g., actor hears an enemy+                      && null closeFoes  -- the enemy not visible; a trap!+          -- 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+      oursHearing <- filterM actorHearning oursNotMeleeing+      oursNotHearing <- filterM (fmap not . actorHearning) oursNotMeleeing+      let targetTEnemy (_, (TEnemy{}, _)) = True+          targetTEnemy (_, (TEnemyPos{}, _)) = True+          targetTEnemy _ = False+          (oursTEnemy, oursOther) = partition targetTEnemy oursNotHearing+          -- These are not necessarily stuck (perhaps can go around),+          -- but their current path is blocked by friends.+          targetBlocked our@((_aid, _b), (_tgt, (path, _etc))) =+            let next = case path of+                  [] -> assert `failure` our+                  [_goal] -> Nothing+                  _ : q : _ -> Just q+            in any ((== next) . Just . bpos . snd) ours+-- TODO: stuck actors are picked while others close could approach an enemy;+-- we should detect stuck actors (or one-sided stuck)+-- so far we only detect blocked and only in Other mode+--             && not (aid == oldAid && waitedLastTurn b time)  -- not stuck+-- this only prevents staying stuck+          (oursBlocked, oursPos) = partition targetBlocked oursOther+          -- Lower overhead is better.+          overheadOurs :: ((ActorId, Actor), (Target, PathEtc))+                       -> (Int, Int, Bool)+          overheadOurs our@((aid, b), (_, (_, (goal, d)))) =+            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))+              , aid /= oldAid )+            else+              -- Keep proper formation, not too dense, not to sparse.+              let+                -- TODO: vary the parameters according to the stage of game,+                -- enough equipment or not, game mode, level map, etc.+                minSpread = 7+                maxSpread = 12 * 2+                dcaptain p =+                  chessDistVector $ bpos captainBody `vectorToFrom` p+                dsergeant p =+                  chessDistVector $ bpos sergeantBody `vectorToFrom` p+                minDist | aid == captain = dsergeant (bpos b)+                        | aid == sergeant = dcaptain (bpos b)+                        | otherwise = dsergeant (bpos b)+                                      `min` dcaptain (bpos b)+                pDist p = dcaptain p + dsergeant p+                sumDist = pDist (bpos b)+                -- Positive, if the goal gets us closer to the party.+                diffDist = sumDist - pDist goal+                minCoeff | minDist < minSpread =+                  (minDist - minSpread) `div` 3+                  - if aid == oldAid then 3 else 0+                         | otherwise = 0+                explorationValue = diffDist * (sumDist `div` 4)+-- TODO: this half is not yet ready:+-- instead spread targets between actors; moving many actors+-- to a single target and stopping and starting them+-- is very wasteful; also, pick targets not closest to the actor in hand,+-- but to the sum of captain and sergant or something+                sumCoeff | sumDist > maxSpread = - explorationValue+                         | otherwise = 0+              in ( if d == 0 then d+                   else max 1 $ minCoeff + if d < 10+                                           then 3 + d `div` 4+                                           else 9 + d `div` 10+                 , sumCoeff+                 , aid /= oldAid )+          sortOurs = sortBy $ comparing overheadOurs+          goodGeneric ((aid, b), (_tgt, _pathEtc)) =+            not (aid == oldAid && waitedLastTurn b)  -- not stuck+          goodTEnemy our@((_aid, b), (TEnemy{}, (_path, (goal, _d)))) =+            not (adjacent (bpos b) goal) -- not in melee range already+            && goodGeneric our+          goodTEnemy our = goodGeneric our+          oursWeakGood = filter goodTEnemy oursWeak+          oursTEnemyGood = filter goodTEnemy oursTEnemy+          oursPosGood = filter goodGeneric oursPos+          oursMeleeingGood = filter goodGeneric oursMeleeing+          oursHearingGood = filter goodTEnemy oursHearing+          oursBlockedGood = filter goodGeneric oursBlocked+          candidates = [ sortOurs oursWeakGood+                       , sortOurs oursTEnemyGood+                       , sortOurs oursPosGood+                       , sortOurs oursMeleeingGood+                       , sortOurs oursHearingGood+                       , sortOurs oursBlockedGood+                       ]+      case filter (not . null) candidates of+        l@(c : _) : _ -> do+          let best = takeWhile ((== overheadOurs c) . overheadOurs) l+              freq = uniformFreq "candidates for AI leader" best+          ((aid, b), _) <- rndToAction $ frequency freq+          s <- getState+          modifyClient $ updateLeader aid s+          return (aid, b)+        _ -> return (oldAid, oldBody)
+ Game/LambdaHack/Client/AI/PickTargetClient.hs view
@@ -0,0 +1,310 @@+-- | Let AI pick the best target for an actor.+module Game.LambdaHack.Client.AI.PickTargetClient+  ( targetStrategy+  ) where++import Control.Exception.Assert.Sugar+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Maybe++import Game.LambdaHack.Client.AI.ConditionClient+import Game.LambdaHack.Client.AI.Preferences+import Game.LambdaHack.Client.AI.Strategy+import Game.LambdaHack.Client.Bfs+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 qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ModeKind++-- | 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+  cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops+  itemToF <- itemToFullClient+  modifyClient $ \cli -> cli { sbfsD = EM.delete aid (sbfsD cli)+                             , seps = seps cli + 773 }  -- randomize paths+  b <- getsState $ getActorBody aid+  activeItems <- activeItemsClient aid+  lvl@Level{lxsize, lysize} <- getLevel $ blid b+  let stepAccesible mtgt@(Just (_, (p : q : _ : _, _))) = -- goal not adjacent+        if accessible cops lvl p q then mtgt else Nothing+      stepAccesible mtgt = mtgt  -- goal can be inaccessible, e.g., suspect+      createPath :: Target -> m (Maybe (Target, PathEtc))+      createPath tgt = do+        mpos <- aidTgtToPos aid (blid b) (Just tgt)+        case mpos of+          Nothing -> return Nothing+          Just p -> do+            (bfs, mpath) <- getCacheBfsAndPath aid p+            return $! case mpath of+              Nothing -> Nothing+              Just path -> Just (tgt, ( bpos b : path+                                      , (p, fromMaybe (assert `failure` mpath)+                                            $ accessBfs bfs p) ))+  mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  oldTgtUpdatedPath <- case mtgtMPath of+    Just (tgt, Just path) -> do+      mvalidPos <- aidTgtToPos aid (blid b) (Just tgt)+      if isNothing mvalidPos then return Nothing  -- wrong level+      else return $! case path of+        (p : q : rest, (goal, len)) -> stepAccesible $+          if bpos b == p+          then Just (tgt, path)  -- no move last turn+          else if bpos b == q+               then Just (tgt, (q : rest, (goal, len - 1)))  -- step along path+               else Nothing  -- veered off the path+        ([p], (goal, _)) -> do+          assert (p == goal `blame` (aid, b, mtgtMPath)) skip+          if bpos b == p then+            Just (tgt, path)  -- goal reached; stay there picking up items+          else+            Nothing  -- somebody pushed us off the goal; let's target again+        ([], _) -> assert `failure` (aid, b, mtgtMPath)+    Just (tgt@TEnemyPos{}, Nothing) ->+      -- special case, TEnemyPos would be lost otherwise+      createPath tgt+    Just (_, Nothing) -> return Nothing  -- path invalidated, e.g. UpdSpotActor+    Nothing -> return Nothing  -- no target assigned yet+  assert (not $ bproj b) skip  -- 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+  -- TODO: we assume the actor eventually becomes a leader (or has the same+  -- set of abilities as the leader, anyway) and set his target accordingly.+  actorSk <- actorSkillsClient aid (Just aid)+  condCanProject <- condCanProjectM aid+  condMeleeBad <- condMeleeBadM aid+  condHpTooLow <- condHpTooLowM 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+  -- (then we have to target, but keep the distance, we can do similarly for+  -- wounded or alone actors, perhaps only until they are shot first time,+  -- and only if they can shoot at the moment)+  fightsSpawners <- fightsAgainstSpawners (bfid b)+  explored <- getsClient sexplored+  smellRadius <- sumOrganEqpClient Effect.EqpSlotAddSmell aid+  let canSmell = smellRadius > 0+      meleeNearby | fightsSpawners = nearby `div` 2  -- not aggresive+                  | otherwise = nearby+      rangedNearby = 2 * meleeNearby+      targetableMelee body =+        chessDist (bpos body) (bpos b) < meleeNearby+        && not 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 =+        case totalUsefulness cops b activeItems fact (itemToF iid k) of+          Just (v, _) -> v+          Nothing -> 30  -- experimenting is fun+      desirableItem iid item k+        | fightsSpawners = itemUsefulness iid k /= 0+                           || Effect.Precious `elem` jfeature item+        | otherwise = itemUsefulness iid k /= 0+      desirableBag bag = any (\(iid, k) ->+                               desirableItem iid (itemD EM.! iid) k)+                         $ 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+      setPath :: Target -> m (Strategy (Target, Maybe PathEtc))+      setPath tgt = do+        mpath <- createPath tgt+        return $! returN "pickNewTarget"+               $ maybe (tgt, Nothing) (\(t, p) -> (t, Just p)) mpath+      pickNewTarget :: m (Strategy (Target, Maybe PathEtc))+      pickNewTarget = do+        -- TODO: for foes, items, etc. consider a few nearby, not just one+        cfoes <- closestFoes nearbyFoes aid+        case cfoes of+          (_, (aid2, _)) : _ -> setPath $ TEnemy aid2 False+          [] -> do+            -- Tracking enemies is more important than exploring,+            -- and smelling actors are usually blind, so bad at exploring.+            -- TODO: prefer closer items to older smells+            smpos <- if canSmell+                     then closestSmell aid+                     else return []+            case smpos of+              [] -> do+                citems <- if EM.findWithDefault 0 AbMoveItem actorSk > 0+                          then closestItems aid+                          else return []+                case filter desirable citems of+                  [] | not (playerLeader (gplayer fact)) -> 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+                              [] -> 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+                              p : _ -> setPath $ TPoint (blid b) p+                          p : _ -> setPath $ TPoint (blid b) p+                      Just p -> setPath $ TPoint (blid b) p+                  (_, (p, _)) : _ -> setPath $ TPoint (blid b) p+              (_, (p, _)) : _ -> setPath $ TPoint (blid b) p+      tellOthersNothingHere pos = do+        let f (tgt, _) = case tgt of+              TEnemyPos _ lid p _ -> p /= pos || lid /= blid b+              _ -> True+        modifyClient $ \cli -> cli {stargetD = EM.filter f (stargetD cli)}+        pickNewTarget+      updateTgt :: Target -> PathEtc+                -> m (Strategy (Target, Maybe PathEtc))+      updateTgt oldTgt updatedPath@(_, (_, len)) = case oldTgt of+        TEnemy a _ -> do+          body <- getsState $ getActorBody a+          if not focused  -- prefers closer foes+             && a `notElem` map fst nearbyFoes  -- old one not close enough+             || blid body /= blid b  -- wrong level+             || actorDying body  -- foe already dying+          then pickNewTarget+          else if bpos body == fst (snd updatedPath)+               then return $! returN "TEnemy" (oldTgt, Just updatedPath)+                      -- The enemy didn't move since the target acquired.+                      -- If any walls were added that make the enemy+                      -- unreachable, AI learns that the hard way,+                      -- as soon as it bumps into them.+               else do+                 let p = bpos body+                 (bfs, mpath) <- getCacheBfsAndPath aid p+                 case mpath of+                   Nothing -> pickNewTarget  -- enemy became unreachable+                   Just path ->+                      return $! returN "TEnemy"+                        (oldTgt, Just ( bpos b : path+                                      , (p, fromMaybe (assert `failure` mpath)+                                            $ accessBfs bfs p) ))+        TEnemyPos _ lid p _ ->+          -- 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+          then pickNewTarget+          else if p == bpos b+               then tellOthersNothingHere p+               else 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+          if lid /= blid b  -- wrong level+             -- Below we check the target could not be picked again in+             -- pickNewTarget, and only in this case it is invalidated.+             -- This ensures targets are eventually reached (unless a foe+             -- shows up) and not changed all the time mid-route+             -- to equally interesting, but perhaps a bit closer targets,+             -- most probably already targeted by other actors.+             || (EM.findWithDefault 0 AbMoveItem actorSk <= 0  -- closestItems+                 || not (desirableBag (lvl `atI` pos)))+                && (not canSmell  -- closestSmell+                    || pos == bpos b  -- in case server resends deleted smell+                    || let sml =+                             EM.findWithDefault timeZero pos (lsmell lvl)+                       in sml `timeDeltaToFrom` ltime lvl <= Delta timeZero)+                && let t = lvl `at` pos+                   in if ES.notMember lid explored+                      then t /= unknownId  -- closestUnknown+                           && not (Tile.isSuspect cotile t)  -- closestSuspect+                      else  -- closestTriggers+                        -- Try to kill that very last enemy for his loot before+                        -- leaving the level or dungeon.+                        not (null allFoes)+                        || -- If all explored, escape/block escapes.+                           (EM.findWithDefault 0 AbTrigger actorSk <= 0+                            || not (Tile.isEscape cotile t && allExplored))+                           -- The next case is stairs in closestTriggers.+                           -- We don't determine if the stairs are interesting+                           -- (this changes with time), but allow the actor+                           -- to reach them and then retarget.+                           && not (pos /= bpos b && Tile.isStair cotile t)+                           -- The remaining case is furthestKnown. This is+                           -- always an unimportant target, so we forget it+                           -- if the actor is stuck (could move, but waits).+                           && let isStuck =+                                    waitedLastTurn b+                                    && (oldLeader == aid+                                        || isAllMoveFact cops fact)+                              in not (pos /= bpos b+                                      && not isStuck+                                      && allExplored)+          then pickNewTarget+          else return $! returN "TPoint" (oldTgt, Just updatedPath)+        TVector{} | len > 1 ->+          return $! returN "TVector" (oldTgt, Just updatedPath)+        TVector{} -> pickNewTarget+  case oldTgtUpdatedPath of+    Just (oldTgt, updatedPath) -> updateTgt oldTgt updatedPath+    Nothing -> pickNewTarget
+ Game/LambdaHack/Client/AI/Preferences.hs view
@@ -0,0 +1,130 @@+-- | Actor preferences for targets and actions based on actor attributes.+module Game.LambdaHack.Client.AI.Preferences+  ( totalUsefulness, effectToBenefit+  ) where++import qualified Control.Monad.State as St+import qualified Data.EnumMap.Strict as EM+import Data.Maybe++import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Dice as Dice+import qualified Game.LambdaHack.Common.Effect as Effect+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.Misc+import Game.LambdaHack.Content.ItemKind++-- | How much AI benefits from applying the effect. Multipllied by item p.+-- Negative means harm to the enemy when thrown at him. Effects with zero+-- benefit won't ever be used, neither actively nor passively.+effectToBenefit :: Kind.COps -> Actor -> [ItemFull] -> Faction+                -> Effect.Effect Int -> Int+effectToBenefit cops b activeItems fact eff =+  let isHorror = isHorrorFact cops fact+  in case eff of+    Effect.NoEffect _ -> 0+    Effect.RefillHP p ->+      let hpMax = sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems+      in if p > 0+         then 1 + 10 * min p (fromIntegral $ (xM hpMax - bhp b) `divUp` oneM)+         else max (-99) (10 * p)+    Effect.Hurt d -> -(min 99 $ round (10 * Dice.meanDice d))+    Effect.RefillCalm p ->+      let calmMax = sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems+      in if p > 0+         then 1 + min p (fromIntegral $ (xM calmMax - bcalm b) `divUp` oneM)+         else max (-20) p+    Effect.Dominate -> -200+    Effect.Impress -> -10+    Effect.CallFriend p -> 20 * p+    Effect.Summon{} | isHorror -> 1    -- probably generates friends or crazies+    Effect.Summon{} -> 0               -- probably generates enemies+    Effect.CreateItem p -> 20 * p+    Effect.ApplyPerfume -> -10+    Effect.Burn p -> -15 * p           -- usually splash damage, etc.+    Effect.Ascend{} -> 1               -- change levels sensibly, in teams+    Effect.Escape{} -> 10000           -- AI wants to win; spawners to guard+    Effect.Paralyze p -> -20 * p+    Effect.InsertMove p -> 50 * p+    Effect.DropBestWeapon -> -50+    Effect.DropEqp ' ' False -> -80+    Effect.DropEqp ' ' True -> -100+    Effect.DropEqp _ False -> -40+    Effect.DropEqp _ True -> -50+    Effect.SendFlying _ -> -10  -- but useful on self sometimes, too+    Effect.PushActor _ -> -10  -- but useful on self sometimes, too+    Effect.PullActor _ -> -10+    Effect.Teleport p | p < 5 -> 5 * p  -- blink to shoot at foe+    Effect.Teleport p | p < 10 -> 1  -- neither escape nor repositioning+    Effect.Teleport p -> -5 * p  -- get rid of the foe+    Effect.PolyItem _ -> 0  -- AI would loop+    Effect.Identify _ -> 0  -- AI would loop+    Effect.ActivateInv ' ' -> -100+    Effect.ActivateInv _ -> -50+    Effect.Explode _ -> -10+    Effect.OneOf _ -> 1  -- usually a mixed blessing, but slightly beneficial+    Effect.OnSmash _ -> -10+    Effect.TimedAspect k asp -> k * (aspectToBenefit cops b asp) `div` 50++-- | Return the value to add to effect value and another to multiply it.+aspectToBenefit :: Kind.COps -> Actor -> Effect.Aspect Int -> Int+aspectToBenefit _cops _b asp =+  case asp of+    Effect.Periodic{} -> 0+    Effect.AddMaxHP p -> p * 10+    Effect.AddMaxCalm p -> p `divUp` 2+    Effect.AddSpeed p -> p * 10000+    Effect.AddSkills m -> 5 * sum (EM.elems m)+    Effect.AddHurtMelee p -> p `divUp` 3+    Effect.AddHurtRanged p -> p `divUp` 5+    Effect.AddArmorMelee p -> p `divUp` 5+    Effect.AddArmorRanged p -> p `divUp` 10+    Effect.AddSight p -> p * 10+    Effect.AddSmell p -> p * 2+    Effect.AddLight p -> p * 10++-- | Determine the total benefit from having an item in eqp or inv,+-- according to item type, and also the benefit confered by equipping the item+-- and from meleeing with it or applying it or throwing it.+totalUsefulness :: Kind.COps -> Actor -> [ItemFull] -> Faction -> ItemFull+                -> Maybe (Int, (Int, Int))+totalUsefulness cops b activeItems fact itemFull =+  let ben effects aspects =+        let effBens = map (effectToBenefit cops b activeItems fact) effects+            aspBens = map (aspectToBenefit cops b) aspects+            periodicEffBens =+              case strengthFromEqpSlot Effect.EqpSlotPeriodic itemFull of+                Nothing -> []+                Just in100 -> map (\eff -> eff * in100 `div` 5) effBens+            selfBens = aspBens ++ periodicEffBens+            eqpSum = if not (null selfBens) && minimum selfBens < -10+                                            && maximum selfBens > 10+                     then 0  -- significant mixed blessings out of AI control+                     else sum selfBens+            effSum = sum effBens+            isWeapon =+              isJust (strengthFromEqpSlot Effect.EqpSlotWeapon itemFull)+            totalSum = if goesIntoInv $ itemBase itemFull+                       then effSum+                       else if isWeapon+                            then effSum + eqpSum+                            else eqpSum+        in (totalSum, (eqpSum, effSum))+  in case itemDisco itemFull of+    Just ItemDisco{itemAE=Just ItemAspectEffect{jaspects, jeffects}} ->+      Just $ ben jeffects jaspects+    Just ItemDisco{itemKind=ItemKind{iaspects, ieffects}} ->+      let travA x =+            St.evalState (Effect.aspectTrav x (return . round . Dice.meanDice))+                         ()+          jaspects = map travA iaspects+          travE x =+            St.evalState (Effect.effectTrav x (return . round . Dice.meanDice))+                         ()+          jeffects = map travE ieffects+      in Just $ ben jeffects jaspects+    _ -> Nothing
+ Game/LambdaHack/Client/AI/Strategy.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE 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+  ( Strategy, nullStrategy, liftFrequency+  , (.|), reject, (.=>), only, bestVariant, renameStrategy, returN, mapStrategyM+  ) where++import Control.Applicative+import Control.Monad+import Data.Maybe+import Data.Text (Text)++import Game.LambdaHack.Common.Frequency as Frequency+import Game.LambdaHack.Common.Msg++-- | A strategy is a choice of (non-empty) frequency tables+-- of possible actions.+newtype Strategy a = Strategy { runStrategy :: [Frequency a] }+  deriving Show++-- | Strategy is a monad. TODO: Can we write this as a monad transformer?+instance Monad Strategy where+  {-# INLINE return #-}+  return x = Strategy $ return $! uniformFreq "Strategy_return" [x]+  m >>= f  = normalizeStrategy $ Strategy+    [ toFreq name [ (p * q, b)+                  | (p, a) <- runFrequency x+                  , y <- runStrategy (f a)+                  , (q, b) <- runFrequency y+                  ]+    | x <- runStrategy m+    , let name = "Strategy_bind (" <> nameFrequency x <> ")"]++instance Functor Strategy where+  fmap f (Strategy fs) = Strategy (map (fmap f) fs)++instance Applicative Strategy where+  pure  = return+  (<*>) = ap++instance MonadPlus Strategy where+  mzero = Strategy []+  {-# INLINE mplus #-}+  mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys)++instance Alternative Strategy where+  (<|>) = mplus+  empty = mzero++normalizeStrategy :: Strategy a -> Strategy a+normalizeStrategy (Strategy fs) = Strategy $ filter (not . nullFreq) fs++nullStrategy :: Strategy a -> Bool+nullStrategy strat = null $ runStrategy strat++-- | Strategy where only the actions from the given single frequency table+-- can be picked.+liftFrequency :: Frequency a -> Strategy a+liftFrequency f = normalizeStrategy $ Strategy $ return f++infixr 2 .|++-- | Strategy with the actions from both argument strategies,+-- with original frequencies.+(.|) :: Strategy a -> Strategy a -> Strategy a+(.|) = mplus++-- | Strategy with no actions at all.+reject :: Strategy a+reject = mzero++infix 3 .=>++-- | Conditionally accepted strategy.+(.=>) :: Bool -> Strategy a -> Strategy a+p .=> m | p         = m+        | otherwise = mzero++-- | Strategy with all actions not satisfying the predicate removed.+-- The remaining actions keep their original relative frequency values.+only :: (a -> Bool) -> Strategy a -> Strategy a+only p s = normalizeStrategy $ do+  x <- s+  p x .=> return x++-- | When better choices are towards the start of the list,+-- this is the best frequency of the strategy.+bestVariant :: Strategy a -> Frequency a+bestVariant (Strategy []) = mzero+bestVariant (Strategy (f : _)) = f++-- | Overwrite the description of all frequencies within the strategy.+renameStrategy :: Text -> Strategy a -> Strategy a+renameStrategy newName (Strategy fs) = Strategy $ map (renameFreq newName) fs++-- | Like 'return', but pick a name of the single frequency.+returN :: Text -> a -> Strategy a+returN name x = Strategy $ return $! uniformFreq name [x]++mapStrategyM :: Monad m => (a -> m (Maybe b)) -> Strategy a -> m (Strategy b)+mapStrategyM f s = do+  let mapFreq freq = do+        let g (k, a) = do+              mb <- f a+              return $! (k,) <$> mb+        lbm <- mapM g $ runFrequency freq+        return $! toFreq "mapStrategyM" $ catMaybes lbm+      ls = runStrategy s+  lt <- mapM mapFreq ls+  return $! normalizeStrategy $ Strategy lt
− Game/LambdaHack/Client/Action.hs 
@@ -1,887 +0,0 @@-{-# LANGUAGE TupleSections #-}--- | Game action monads and basic building blocks for human and computer--- player actions. Has no access to the the main action type.--- Does not export the @liftIO@ operation nor a few other implementation--- details.-module Game.LambdaHack.Client.Action-  ( -- * Action monads-    MonadClient( getClient, getsClient, putClient, modifyClient, saveClient )-  , MonadClientUI-  , MonadClientReadServer(..), MonadClientWriteServer(..)-  , SessionUI(..), ConnFrontend(..), connFrontend-    -- * Executing actions-  , mkConfigUI-    -- * Accessors to the game session Reader and the Perception Reader(-like)-  , askBinding, getPerFid-    -- * History and report-  , msgAdd, msgReset, recordHistory-    -- * Key input-  , getKeyOverlayCommand, getInitConfirms, stopPlayBack, stopRunning-    -- * Display and key input-  , displayFrames, displayMore, displayYesNo, displayChoiceUI-    -- * Generate slideshows-  , promptToSlideshow, overlayToSlideshow, overlayToBlankSlideshow-    -- * Draw frames-  , drawOverlay, animate-    -- * Assorted primitives-  , restoreGame, removeServerSave, displayPush, scoreToSlideshow-  , rndToAction, getArenaUI, getLeaderUI, targetDescLeader, viewedLevel-  , aidTgtToPos, aidTgtAims, leaderTgtToPos, leaderTgtAims, cursorToPos-  , partAidLeader, partActorLeader, unexploredDepth-  , getCacheBfsAndPath, getCacheBfs, accessCacheBfs, actorAimsPos-  , closestUnknown, closestSmell, furthestKnown, closestTriggers-  , closestItems, closestFoes, actorAbilities-  , debugPrint-  ) where--import Control.Arrow ((&&&))-import Control.Concurrent-import Control.Concurrent.STM-import Control.DeepSeq-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Control.Monad.State as St-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import qualified Data.Ini as Ini-import qualified Data.Ini.Reader as Ini-import qualified Data.Ini.Types as Ini-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Monoid-import Data.Ord-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU-import System.Directory-import System.FilePath-import System.Time-import Text.Read--import Game.LambdaHack.Client.Action.ActionClass-import Game.LambdaHack.Client.Binding-import Game.LambdaHack.Client.Config-import Game.LambdaHack.Client.Draw-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Ability (Ability)-import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Animation-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.HighScore as HighScore-import Game.LambdaHack.Common.HumanCmd-import qualified Game.LambdaHack.Common.Key as K-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Random-import qualified Game.LambdaHack.Common.Save as Save-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ActorKind-import Game.LambdaHack.Content.FactionKind-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.TileKind-import qualified Game.LambdaHack.Frontend as Frontend-import Game.LambdaHack.Utils.File--debugPrint :: MonadClient m => Text -> m ()-debugPrint t = do-  sdbgMsgCli <- getsClient $ sdbgMsgCli . sdebugCli-  when sdbgMsgCli $ liftIO $ Save.delayPrint t--connFrontend :: FactionId -> Frontend.ChanFrontend -> ConnFrontend-connFrontend fid fromF = ConnFrontend-  { readConnFrontend =-      liftIO $ atomically $ readTQueue fromF-  , writeConnFrontend = \efr -> do-      let toF = Frontend.toMulti Frontend.connMulti-      liftIO $ atomically $ writeTQueue toF (fid, efr)-  }--displayFrame :: MonadClientUI m => Bool -> Maybe SingleFrame -> m ()-displayFrame isRunning mf = do-  ConnFrontend{writeConnFrontend} <- getsSession sfconn-  let frame = case mf of-        Nothing -> AcDelay-        Just fr | isRunning -> AcRunning fr-        Just fr -> AcNormal fr-  writeConnFrontend $ Frontend.FrontFrame frame--promptGetKey :: MonadClientUI m => [K.KM] -> SingleFrame -> m K.KM-promptGetKey frontKM frontFr = do-  lastPlayOld <- getsClient slastPlay-  km <- case lastPlayOld of-    km : kms | null frontKM || km `elem` frontKM -> do-      displayFrame False $ Just frontFr-      modifyClient $ \cli -> cli {slastPlay = kms}-      return km-    _ -> do-      unless (null lastPlayOld) stopPlayBack  -- something went wrong-      ConnFrontend{..} <- getsSession sfconn-      writeConnFrontend Frontend.FrontKey {..}-      readConnFrontend-  (seqCurrent, seqPrevious, k) <- getsClient slastRecord-  let slastRecord = (km : seqCurrent, seqPrevious, k)-  modifyClient $ \cli -> cli {slastRecord}-  return km--stopPlayBack :: MonadClientUI m => m ()-stopPlayBack = do-  modifyClient $ \cli -> cli-    { slastPlay = []-    , slastRecord = let (seqCurrent, seqPrevious, _) = slastRecord cli-                    in (seqCurrent, seqPrevious, 0)-    , swaitTimes = - swaitTimes cli-    }-  stopRunning--stopRunning :: MonadClientUI m => m ()-stopRunning = do-  srunning <- getsClient srunning-  case srunning of-    Nothing -> return ()-    Just RunParams{runLeader} -> do-      -- Switch to the original leader, from before the run start, unless dead.-      side <- getsClient sside-      fact <- getsState $ (EM.! side) . sfactionD-      arena <- getArenaUI-      s <- getState-      when (memActor runLeader arena s && not (isSpawnFact fact)) $-        modifyClient $ updateLeader runLeader s-      modifyClient (\cli -> cli { srunning = Nothing })---- | Display a slideshow, awaiting confirmation for each slide except the last.-getInitConfirms :: MonadClientUI m-                => ColorMode -> [K.KM] -> Slideshow -> m Bool-getInitConfirms dm frontClear slides = do-  ConnFrontend{..} <- getsSession sfconn-  let (onBlank, ovs) = slideshow slides-  frontSlides <- mapM (drawOverlay onBlank dm) ovs-  -- The first two cases are optimizations:-  case frontSlides of-    [] -> return True-    [x] -> do-      displayFrame False $ Just x-      return True-    _ -> do-      writeConnFrontend Frontend.FrontSlides{..}-      km <- readConnFrontend-      return $! km /= K.escKey---- | Get the key binding.-askBinding :: MonadClientUI m => m Binding-askBinding = getsSession sbinding---- | Add a message to the current report.-msgAdd :: MonadClientUI m => Msg -> m ()-msgAdd msg = modifyClient $ \d -> d {sreport = addMsg (sreport d) msg}---- | Wipe out and set a new value for the current report.-msgReset :: MonadClient m => Msg -> m ()-msgReset msg = modifyClient $ \d -> d {sreport = singletonReport msg}---- | Store current report in the history and reset report.-recordHistory :: MonadClient m => m ()-recordHistory = do-  StateClient{sreport, shistory} <- getClient-  unless (nullReport sreport) $ do-    ConfigUI{configHistoryMax} <- getsClient sconfigUI-    msgReset ""-    let nhistory = takeHistory configHistoryMax $! addReport sreport shistory-    modifyClient $ \cli -> cli {shistory = nhistory}---- | 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---- | Display an overlay and wait for a human player command.-getKeyOverlayCommand :: MonadClientUI m => Bool -> Overlay -> m K.KM-getKeyOverlayCommand onBlank overlay = do-  frame <- drawOverlay onBlank ColorFull overlay-  -- Give the previous client time to display his frames.-  liftIO $ threadDelay 1000-  promptGetKey [] frame---- | Push frames or delays to the frame queue.-displayFrames :: MonadClientUI m => Frames -> m ()-displayFrames = mapM_ (displayFrame False)---- | 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}-             , K.escKey-             ]-  K.KM {key} <- promptGetKey keys frame-  case key of-    K.Char 'y' -> return True-    _          -> return False---- | Display a msg with a @more@ prompt. Return value indicates if the player--- tried to cancel/escape.-displayMore :: MonadClientUI m => ColorMode -> Msg -> m Bool-displayMore dm prompt = do-  slides <- promptToSlideshow $ prompt <+> moreMsg-  -- Two frames drawn total (unless 'prompt' very long).-  getInitConfirms dm [] $ slides <> toSlideshow False [[]]---- | Print a yes/no question and return the player's answer. Use black--- and white colours to turn player's attention to the choice.-displayYesNo :: MonadClientUI m => ColorMode -> Msg -> m Bool-displayYesNo dm prompt = do-  sli <- promptToSlideshow $ prompt <+> yesnoMsg-  frame <- drawOverlay False dm $ head . snd $ slideshow sli-  getYesNo frame---- TODO: generalize getInitConfirms and displayChoiceUI to a single op--- | Print a prompt and an overlay and wait for a player keypress.--- If many overlays, scroll screenfuls with SPACE. Do not wrap screenfuls--- (in some menus @?@ cycles views, so the user can restart from the top).-displayChoiceUI :: 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.KM {key=K.Space, modifier=K.NoModifier}-        , K.escKey ]-        ++ 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---- | The prompt is shown after the current message, but not added to history.--- This is useful, e.g., in targeting mode, not to spam history.-promptToSlideshow :: MonadClientUI m => Msg -> m Slideshow-promptToSlideshow prompt = overlayToSlideshow prompt emptyOverlay---- | The prompt is shown after the current message at the top of each slide.--- Together they may take more than one line. The prompt is not added--- to history. The portions of overlay that fit on the the rest--- of the screen are displayed below. As many slides as needed are shown.-overlayToSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow-overlayToSlideshow prompt overlay = do-  lid <- getArenaUI-  Level{lxsize, lysize} <- getLevel lid  -- TODO: screen length or viewLevel-  sreport <- getsClient sreport-  let msg = splitReport lxsize (addMsg sreport prompt)-  return $! splitOverlay False (lysize + 1) msg overlay--overlayToBlankSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow-overlayToBlankSlideshow prompt overlay = do-  lid <- getArenaUI-  Level{lysize} <- getLevel lid  -- TODO: screen length or viewLevel-  return $! splitOverlay True (lysize + 3) (toOverlay [prompt]) overlay---- | Draw the current level with the overlay on top.-drawOverlay :: MonadClientUI m => Bool -> ColorMode -> Overlay -> m SingleFrame-drawOverlay onBlank dm over = do-  cops <- getsState scops-  lid <- viewedLevel-  mleader <- getsClient _sleader-  s <- getState-  cli <- getClient-  per <- getPerFid lid-  tgtPos <- leaderTgtToPos-  cursorPos <- cursorToPos-  let pathFromLeader leader =-        maybe (return Nothing) (fmap Just . getCacheBfsAndPath leader) tgtPos-  bfsmpath <- maybe (return Nothing) pathFromLeader mleader-  tgtDesc <- maybe (return "------") targetDescLeader mleader-  cursorDesc <- targetDescCursor-  return $! draw onBlank dm cops per lid mleader cursorPos tgtPos-                 bfsmpath cli s cursorDesc tgtDesc over---- TODO: if more slides, don't take head, but do as in getInitConfirms,--- but then we have to clear the messages or they get redisplayed--- 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-  sls <- promptToSlideshow ""-  let slide = head . snd $ slideshow sls-  frame <- drawOverlay False ColorFull slide-  -- Visually speed up (by remving all empty frames) the show of the sequence-  -- of the move frames if the player is running.-  srunning <- getsClient srunning-  displayFrame (isJust srunning) $ Just frame--scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow-scoreToSlideshow total status = do-  fid <- getsClient sside-  fact <- getsState $ (EM.! fid) . sfactionD-  table <- getsState shigh-  time <- getsState stime-  date <- liftIO getClockTime-  scurDifficulty <- getsClient scurDifficulty-  let showScore (ntable, pos) = HighScore.highSlideshow ntable pos status-      diff | not $ playerUI $ gplayer fact = 0-           | otherwise = scurDifficulty-  return $! maybe mempty showScore-            $ HighScore.register table total time status date diff--restoreGame :: MonadClient m => m (Maybe (State, StateClient))-restoreGame = do-  Kind.COps{corule} <- getsState scops-  let stdRuleset = Kind.stdRuleset corule-      pathsDataFile = rpathsDataFile stdRuleset-      cfgUIName = rcfgUIName stdRuleset-  side <- getsClient sside-  isAI <- getsClient sisAI-  prefix <- getsClient $ ssavePrefixCli . sdebugCli-  let copies = [( "GameDefinition" </> cfgUIName <.> "default"-                , cfgUIName <.> "ini" )]-      name = fromMaybe "save" prefix <.> saveName side isAI-  liftIO $ Save.restoreGame name copies pathsDataFile---- | Assuming the client runs on the same machine and for the same--- user as the server, move the server savegame out of the way.-removeServerSave :: MonadClient m => m ()-removeServerSave = do-  prefix <- getsClient $ ssavePrefixCli . sdebugCli  -- hack: assume the same-  dataDir <- liftIO appDataDir-  let serverSaveFile = dataDir-                       </> fromMaybe "save" prefix-                       <.> serverSaveName-  bSer <- liftIO $ doesFileExist serverSaveFile-  when bSer $ liftIO $ renameFile serverSaveFile (serverSaveFile <.> "bkp")---- | Invoke pseudo-random computation with the generator kept in the state.-rndToAction :: MonadClient m => Rnd a -> m a-rndToAction r = do-  g <- getsClient srandom-  let (a, ng) = St.runState r g-  modifyClient $ \cli -> cli {srandom = ng}-  return a---- TODO: restrict the animation to 'per' before drawing.--- | Render animations on top of the current screen frame.-animate :: MonadClientUI m => LevelId -> Animation -> m Frames-animate arena anim = do-  cops <- getsState scops-  sreport <- getsClient sreport-  mleader <- getsClient _sleader-  Level{lxsize, lysize} <- getLevel arena-  cli <- getClient-  s <- getState-  per <- getPerFid arena-  tgtPos <- leaderTgtToPos-  cursorPos <- cursorToPos-  let pathFromLeader leader =-        maybe (return Nothing) (fmap Just . getCacheBfsAndPath leader) tgtPos-  bfsmpath <- maybe (return Nothing) pathFromLeader mleader-  tgtDesc <- maybe (return "------") targetDescLeader mleader-  cursorDesc <- targetDescCursor-  let over = renderReport sreport-      topLineOnly = truncateToOverlay lxsize over-      basicFrame =-        draw False ColorFull cops per arena mleader-             cursorPos tgtPos bfsmpath cli s cursorDesc tgtDesc topLineOnly-  snoAnim <- getsClient $ snoAnim . sdebugCli-  return $! if fromMaybe False snoAnim-            then [Just basicFrame]-            else renderAnim lxsize lysize basicFrame anim---- | The part of speech describing the actor or a special name if a leader--- of the observer's faction. The actor may not be present in the dungeon.-partActorLeader :: MonadClient m => ActorId -> Actor -> m MU.Part-partActorLeader aid b = do-  mleader <- getsClient _sleader-  return $! case mleader of-    Just leader | aid == leader -> "you"-    _ -> partActor b---- | The part of speech describing the actor (designated by actor id--- and present in the dungeon) or a special name if a leader--- of the observer's faction.-partAidLeader :: MonadClient m => ActorId -> m MU.Part-partAidLeader aid = do-  b <- getsState $ getActorBody aid-  partActorLeader aid b--parseConfigUI :: Ini.Config -> ConfigUI-parseConfigUI cfg =-  let configCommands =-        let mkCommand (ident, keydef) =-              case stripPrefix "Macro_" ident of-                Just _ ->-                  let (key, def) = read keydef-                  in (K.mkKM key, def :: (CmdCategory, HumanCmd))-                Nothing -> assert `failure` "wrong macro id" `twith` ident-            section = Ini.allItems "extra_commands" cfg-        in map mkCommand section-      configHeroNames =-        let toNumber (ident, name) =-              case stripPrefix "HeroName_" ident of-                Just n -> (read n, T.pack name)-                Nothing -> assert `failure` "wrong hero name id" `twith` ident-            section = Ini.allItems "hero_names" cfg-        in map toNumber section-      getOption :: forall a. Read a => String -> a-      getOption optionName =-        let lookupFail :: forall b. String -> b-            lookupFail err =-              assert `failure` ("config file access failed:" <+> T.pack err)-                     `twith` (optionName, cfg)-            s = fromMaybe (lookupFail "") $ Ini.getOption "ui" optionName cfg-        in either lookupFail id $ readEither s-      configFont = getOption "font"-      configHistoryMax = getOption "historyMax"-      configMaxFps = getOption "maxFps"-      configNoAnim = getOption "noAnim"-      configRunStopMsgs = getOption "runStopMsgs"-  in ConfigUI{..}---- | Read and parse UI config file.-mkConfigUI :: Kind.Ops RuleKind -> IO ConfigUI-mkConfigUI corule = do-  let stdRuleset = Kind.stdRuleset corule-      cfgUIName = rcfgUIName stdRuleset-      commentsUIDefault = init $ map (drop 2) $ lines $ rcfgUIDefault stdRuleset  -- TODO: init is a hack until Ini accepts empty files-      sUIDefault = unlines commentsUIDefault-      cfgUIDefault = either (assert `failure`) id $ Ini.parse sUIDefault-  dataDir <- appDataDir-  let userPath = dataDir </> cfgUIName <.> "ini"-  cfgUser <- do-    cpExists <- doesFileExist userPath-    if not cpExists-      then return Ini.emptyConfig-      else do-        sUser <- readFile userPath-        return $! either (assert `failure`) id $ Ini.parse sUser-  let cfgUI = M.unionWith M.union cfgUser cfgUIDefault  -- user cfg preferred-      conf = parseConfigUI cfgUI-  -- Catch syntax errors in complex expressions ASAP,-  return $! deepseq conf conf---- | Get cached BFS data and path or, if not stored, generate,--- store and return. Due to laziness, they are not calculated until needed.-getCacheBfsAndPath :: forall m. MonadClient m-                   => ActorId -> Point-                   -> m (PointArray.Array BfsDistance, Maybe [Point])-getCacheBfsAndPath aid target = do-  seps <- getsClient seps-  let pathAndStore :: PointArray.Array BfsDistance-                   -> m (PointArray.Array BfsDistance, Maybe [Point])-      pathAndStore bfs = do-        computePath <- computePathBFS aid-        let mpath = computePath target seps bfs-        modifyClient $ \cli ->-          cli {sbfsD = EM.insert aid (bfs, target, seps, mpath) (sbfsD cli)}-        return (bfs, mpath)-  mbfs <- getsClient $ EM.lookup aid . sbfsD-  case mbfs of-    Just (bfs, targetOld, sepsOld, mpath) | targetOld == target-                                            && sepsOld == seps ->-      return (bfs, mpath)-    Just (bfs, _, _, _) -> pathAndStore bfs-    Nothing -> do-      bfs <- computeBFS aid-      pathAndStore bfs--getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)-{-# INLINE getCacheBfs #-}-getCacheBfs aid = do-  mbfs <- getsClient $ EM.lookup aid . sbfsD-  case mbfs of-    Just (bfs, _, _, _) -> return bfs-    Nothing -> fmap fst $ getCacheBfsAndPath aid (Point 0 0)--computeBFS :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)-computeBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do-  b <- getsState $ getActorBody aid-  Level{lxsize, lysize} <- getLevel $ blid b-  let origin = bpos b-      vInitial = PointArray.replicateA lxsize lysize apartBfs-  -- Here we don't want '$!', because we want the BFS data lazy.-  return ${-keep it!-} fillBfs isEnterable passUnknown origin vInitial--computePathBFS :: MonadClient m-               => ActorId-               -> m (Point -> Int -> PointArray.Array BfsDistance-                     -> Maybe [Point])-computePathBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do-  b <- getsState $ getActorBody aid-  let origin = bpos b-  -- Here we don't want '$!', because we want the BFS data lazy.-  return ${-keep it!-} findPathBfs isEnterable passUnknown origin--computeAnythingBFS :: MonadClient m-                   => ((Point -> Point -> MoveLegal)-                       -> (Point -> Point -> Bool)-                       -> ActorId-                       -> m a)-                   -> ActorId-                   -> m a-computeAnythingBFS fAnything aid = do-  cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops-  b <- getsState $ getActorBody aid-  lvl <- getLevel $ blid b-  smarkSuspect <- getsClient smarkSuspect-  sisAI <- getsClient sisAI-  -- We treat doors as an open tile and don't add an extra step for opening-  -- the doors, because other actors open and use them, too,-  -- so it's amortized. We treat unknown tiles specially.-  let -- Suspect tiles treated as a kind of unknown.-      passSuspect = smarkSuspect || sisAI  -- AI checks suspects ASAP-      unknownId = ouniqGroup "unknown space"-      chAccess = checkAccess cops lvl-      chDoorAccess = checkDoorAccess cops lvl-      conditions = catMaybes [chAccess, chDoorAccess]-      -- Legality of move from a known tile, assuming doors freely openable.-      isEnterable :: Point -> Point -> MoveLegal-      isEnterable spos tpos =-        let tt = lvl `at` tpos-            allOK = all (\f -> f spos tpos) conditions-        in if tt == unknownId-           then if allOK-                then MoveToUnknown-                else MoveBlocked-           else if Tile.isSuspect cotile tt-                then if passSuspect && allOK-                     then MoveToUnknown-                     else MoveBlocked-                else if Tile.isPassable cotile tt && allOK-                     then MoveToOpen-                     else MoveBlocked-      -- Legality of move from an unknown tile, assuming unknown are open.-      passUnknown :: Point -> Point -> Bool-      passUnknown = case chAccess of  -- spos is unknown, so not a door-        Nothing -> \_ tpos -> let tt = lvl `at` tpos-                              in tt == unknownId-                                 || passSuspect && Tile.isSuspect cotile tt-        Just ch -> \spos tpos -> let tt = lvl `at` tpos-                                 in (tt == unknownId-                                     || passSuspect-                                        && Tile.isSuspect cotile tt)-                                    && ch spos tpos-  fAnything isEnterable passUnknown aid--accessCacheBfs :: MonadClient m => ActorId -> Point -> m (Maybe Int)-{-# INLINE accessCacheBfs #-}-accessCacheBfs aid target = do-  bfs <- getCacheBfs aid-  return $! accessBfs bfs target--actorAimsPos :: MonadClient m => ActorId -> Point -> m Bool-{-# INLINE actorAimsPos #-}-actorAimsPos aid target = do-  bfs <- getCacheBfs aid-  b <- getsState $ getActorBody aid-  return $! posAimsPos bfs (bpos b) target--targetDesc :: MonadClientUI m => Maybe Target -> m Text-targetDesc target = do-  lidV <- viewedLevel-  mleader <- getsClient _sleader-  case target of-    Just (TEnemy a _) ->-      getsState $ bname . getActorBody a-    Just (TEnemyPos _ lid p _) ->-      return $! if lid == lidV-                then "hot spot" <+> (T.pack . show) p-                else "a hot spot on level" <+> tshow (abs $ fromEnum lid)-    Just (TPoint lid p) ->-      return $! if lid == lidV-                then "exact spot" <+> (T.pack . show) p-                else "an exact spot on level" <+> tshow (abs $ fromEnum lid)-    Just TVector{} ->-      case mleader of-        Nothing -> return "a relative shift"-        Just aid -> do-          tgtPos <- aidTgtToPos aid lidV target-          let invalidMsg = "an invalid relative shift"-              validMsg p = "shift to" <+> (T.pack . show) p-          return $! maybe invalidMsg validMsg tgtPos-    Nothing -> return "cursor location"--targetDescLeader :: MonadClientUI m => ActorId -> m Text-targetDescLeader leader = do-  tgt <- getsClient $ getTarget leader-  targetDesc tgt--targetDescCursor :: MonadClientUI m => m Text-targetDescCursor = do-  scursor <- getsClient scursor-  targetDesc $ Just scursor--getLeaderUI :: MonadClientUI m => m ActorId-getLeaderUI = do-  cli <- getClient-  case _sleader cli of-    Nothing -> assert `failure` "leader expected but not found" `twith` cli-    Just leader -> return leader--getArenaUI :: MonadClientUI m => m LevelId-getArenaUI = do-  mleader <- getsClient _sleader-  case mleader of-    Just leader -> getsState $ blid . getActorBody leader-    Nothing -> do-      side <- getsClient sside-      factionD <- getsState sfactionD-      let fact = factionD EM.! side-      case gquit fact of-        Just Status{stDepth} -> return $! toEnum stDepth-        Nothing -> do-          dungeon <- getsState sdungeon-          let (minD, maxD) =-                case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of-                  (Just ((s, _), _), Just ((e, _), _)) -> (s, e)-                  _ -> assert `failure` "empty dungeon" `twith` dungeon-          return $! max minD $ min maxD $ playerEntry $ gplayer fact--viewedLevel :: MonadClientUI m => m LevelId-viewedLevel = do-  arena <- getArenaUI-  stgtMode <- getsClient stgtMode-  return $! maybe arena tgtLevelId stgtMode---- | Calculate the position of an actor's target.-aidTgtToPos :: MonadClient m-            => ActorId -> LevelId -> Maybe Target -> m (Maybe Point)-aidTgtToPos aid lidV tgt =-  case tgt of-    Just (TEnemy a _) -> do-      body <- getsState $ getActorBody a-      return $! if blid body == lidV-                then Just (bpos body)-                else Nothing-    Just (TEnemyPos _ lid p _) ->-      return $! if lid == lidV then Just p else Nothing-    Just (TPoint lid p) ->-      return $! if lid == lidV then Just p else Nothing-    Just (TVector v) -> do-      b <- getsState $ getActorBody aid-      Level{lxsize, lysize} <- getLevel lidV-      let shifted = shiftBounded lxsize lysize (bpos b) v-      return $! if shifted == bpos b && v /= Vector 0 0-                then Nothing-                else Just shifted-    Nothing -> do-      scursor <- getsClient scursor-      aidTgtToPos aid lidV $ Just scursor---- | Check whether one is permitted to aim at a target--- (this is only checked for actors; positions let player--- shoot at obstacles, e.g., to destroy them).--- This assumes @aidTgtToPos@ does not return @Nothing@.------ Note: Perception is not enough for the check,--- because the target actor can be obscured by a glass wall--- or be out of sight range, but in weapon range.-aidTgtAims :: MonadClient m-           => ActorId -> LevelId -> Maybe Target -> m (Maybe Text)-aidTgtAims aid lidV tgt = do-  case tgt of-    Just (TEnemy a _) -> do-      body <- getsState $ getActorBody a-      let pos = bpos body-      b <- getsState $ getActorBody aid-      if blid b == lidV then do-        aims <- actorAimsPos aid pos-        if aims-          then return Nothing-          else return $ Just "aiming line to the opponent blocked"-      else return $ Just "target opponent not on this level"-    Just TEnemyPos{} -> return $ Just "target opponent not visible"-    Just TPoint{} -> return Nothing-    Just TVector{} -> return Nothing-    Nothing -> do-      scursor <- getsClient scursor-      aidTgtAims aid lidV $ Just scursor--leaderTgtToPos :: MonadClientUI m => m (Maybe Point)-leaderTgtToPos = do-  lidV <- viewedLevel-  mleader <- getsClient _sleader-  case mleader of-    Nothing -> return Nothing-    Just aid -> do-      tgt <- getsClient $ getTarget aid-      aidTgtToPos aid lidV tgt--leaderTgtAims :: MonadClientUI m => m (Maybe Text)-leaderTgtAims = do-  lidV <- viewedLevel-  mleader <- getsClient _sleader-  case mleader of-    Nothing -> return $ Just "no leader to target with"-    Just aid -> do-      tgt <- getsClient $ getTarget aid-      aidTgtAims aid lidV tgt--cursorToPos :: MonadClientUI m => m (Maybe Point)-cursorToPos = do-  lidV <- viewedLevel-  mleader <- getsClient _sleader-  scursor <- getsClient scursor-  case mleader of-    Nothing -> return Nothing-    Just aid -> aidTgtToPos aid lidV $ Just scursor---- | Furthest (wrt paths) known position, except under the actor.-furthestKnown :: MonadClient m => ActorId -> m (Maybe Point)-furthestKnown aid = do-  bfs <- getCacheBfs aid-  getMaxIndex <- rndToAction $ oneOf [ PointArray.maxIndexA-                                     , PointArray.maxLastIndexA ]-  let furthestPos = getMaxIndex bfs-      dist = bfs PointArray.! furthestPos-  return $! if dist <= apartBfs-            then assert `failure` (aid, furthestPos, dist)-            else if dist == succ apartBfs  -- bpos of aid-                 then Nothing-                 else Just furthestPos---- | Closest reachable unknown tile position, if any.-closestUnknown :: MonadClient m => ActorId -> m (Maybe Point)-closestUnknown aid = do-  bfs <- getCacheBfs aid-  getMinIndex <- rndToAction $ oneOf [ PointArray.minIndexA-                                     , PointArray.minLastIndexA ]-  let closestPos = getMinIndex bfs-      dist = bfs PointArray.! closestPos-  if dist >= apartBfs then do-    body <- getsState $ getActorBody aid-    smarkSuspect <- getsClient smarkSuspect-    sisAI <- getsClient sisAI-    let passSuspect = smarkSuspect || sisAI-    when passSuspect $  -- explored fully, including suspect tiles-      modifyClient $ \cli ->-        cli {sexplored = ES.insert (blid body) (sexplored cli)}-    return Nothing-  else return $ Just closestPos---- TODO: this is costly, because target has to be changed every--- turn when walking along trail. But inverting the sort and going--- to the newest smell, while sometimes faster, may result in many--- actors following the same trail, unless we wipe the trail as soon--- as target is assigned (but then we don't know if we should keep the target--- or not, because somebody already followed it). OTOH, trails are not--- common and so if wiped they can't incur a large total cost.--- TODO: remove targets where the smell is likely to get too old by the time--- the actor gets there.--- | Finds smells closest to the actor, except under the actor.-closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Tile.SmellTime))]-closestSmell aid = do-  body <- getsState $ getActorBody aid-  Level{lsmell} <- getLevel $ blid body-  let smells = EM.assocs lsmell-  case smells of-    [] -> return []-    _ -> do-      bfs <- getCacheBfs aid-      let ts = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) smells-          ds = filter (\(d, _) -> d /= 0) ts  -- bpos of aid-      return $! sortBy (comparing (fst &&& timeNegate . snd . snd)) ds---- TODO: We assume linear dungeon in @unexploredD@,--- because otherwise we'd need to calculate shortest paths in a graph, etc.--- | Closest (wrt paths) triggerable open tiles.--- The second argument can ever be true only if there's--- no escape from the dungeon.-closestTriggers :: MonadClient m => Maybe Bool -> Bool -> ActorId -> m [Point]-closestTriggers onlyDir exploredToo aid = do-  Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody aid-  lvl <- getLevel $ blid body-  dungeon <- getsState sdungeon-  explored <- getsClient sexplored-  unexploredD <- unexploredDepth-  let allExplored = ES.size explored == EM.size dungeon-      unexUp = onlyDir /= Just False && unexploredD 1 (blid body)-      unexDown = onlyDir /= Just True && unexploredD (-1) (blid body)-      unexEffect (Effect.Ascend p) = if p > 0 then unexUp else unexDown-      unexEffect _ =-        -- Escape (or guard) only after exploring, for high score, etc.-        allExplored-      isTrigger-        | exploredToo = \t -> Tile.isWalkable cotile t-                              && not (null $ Tile.causeEffects cotile t)-        | otherwise = \t -> Tile.isWalkable cotile t-                            && any unexEffect (Tile.causeEffects cotile t)-      f :: [Point] -> Point -> Kind.Id TileKind -> [Point]-      f acc p t = if isTrigger t then p : acc else acc-  let triggersAll = PointArray.ifoldlA f [] $ ltile lvl-      -- Don't target stairs under the actor. Most of the time they-      -- are blocked and stay so, so we seek other stairs, if any.-      -- If no other stairs in this direction, let's wait here.-      triggers | length triggersAll > 1 = delete (bpos body) triggersAll-               | otherwise = triggersAll-  case triggers of-    [] -> return []-    _ -> do-      bfs <- getCacheBfs aid-      let ds = mapMaybe (\p -> fmap (,p) (accessBfs bfs p)) triggers-      return $! map snd $ sortBy (comparing fst) ds--unexploredDepth :: MonadClient m => m (Int -> LevelId -> Bool)-unexploredDepth = do-  dungeon <- getsState sdungeon-  explored <- getsClient sexplored-  let allExplored = ES.size explored == EM.size dungeon-      unexploredD p =-        let unex lid = allExplored && lescape (dungeon EM.! lid)-                       || ES.notMember lid explored-                       || unexploredD p lid-        in any unex . ascendInBranch dungeon p-  return unexploredD---- | Closest (wrt paths) items.-closestItems :: MonadClient m => ActorId -> m ([(Int, (Point, ItemBag))])-closestItems aid = do-  body <- getsState $ getActorBody aid-  Level{lfloor} <- getLevel $ blid body-  let items = EM.assocs lfloor-  case items of-    [] -> return []-    _ -> do-      bfs <- getCacheBfs aid-      let ds = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) items-      return $! sortBy (comparing fst) ds---- | Closest (wrt paths) enemy actors.-closestFoes :: MonadClient m => ActorId -> m [(Int, (ActorId, Actor))]-closestFoes aid = do-  body <- getsState $ getActorBody aid-  fact <- getsState $ \s -> sfactionD s EM.! bfid body-  foes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid body)-  case foes of-    [] -> return []-    _ -> do-      bfs <- getCacheBfs aid-      let ds = mapMaybe (\x@(_, b) -> fmap (,x) (accessBfs bfs (bpos b))) foes-      return $! sortBy (comparing fst) ds--actorAbilities :: MonadClient m => ActorId -> Maybe ActorId -> m [Ability]-actorAbilities aid mleader = do-  Kind.COps{ coactor=Kind.Ops{okind}-           , cofaction=Kind.Ops{okind=fokind} } <- getsState scops-  body <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid body) . sfactionD-  let factionAbilities-        | Just aid == mleader = fAbilityLeader $ fokind $ gkind fact-        | otherwise = fAbilityOther $ fokind $ gkind fact-  return $! acanDo (okind $ bkind body) `intersect` factionAbilities
− Game/LambdaHack/Client/Action/ActionClass.hs 
@@ -1,57 +0,0 @@-{-# LANGUAGE FunctionalDependencies, RankNTypes #-}--- | Basic type classes for game actions.--- This module should not be imported anywhere except in 'Action'--- and 'TypeAction'.-module Game.LambdaHack.Client.Action.ActionClass where--import qualified Game.LambdaHack.Common.Key as K--import Game.LambdaHack.Client.Binding-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Frontend (FrontReq)---- | 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@.-data SessionUI = SessionUI-  { sfconn   :: !ConnFrontend  -- ^ connection with the frontend-  , sbinding :: !Binding       -- ^ binding of keys to commands-  }---- | Connection method between a client and a frontend.-data ConnFrontend = ConnFrontend-  { readConnFrontend  :: MonadClientUI m => m K.KM-      -- ^ read a keystroke received from the frontend-  , writeConnFrontend :: MonadClientUI m => FrontReq -> m ()-      -- ^ write a UI request to the frontend-  }--class MonadActionRO m => MonadClient m where-  getClient    :: m StateClient-  getsClient   :: (StateClient -> a) -> m a-  modifyClient :: (StateClient -> StateClient) -> m ()-  putClient    :: StateClient -> m ()-  -- We do not provide a MonadIO instance, so that outside of Action/-  -- nobody can subvert the action monads by invoking arbitrary IO.-  liftIO       :: IO a -> m a-  saveClient   :: m ()--class MonadClient m => MonadClientUI m where-  getsSession  :: (SessionUI -> a) -> m a--class MonadClient m => MonadClientReadServer c m | m -> c where-  readServer  :: m c--class MonadClient m => MonadClientWriteServer d m | m -> d where-  writeServer  :: d -> m ()--saveName :: FactionId -> Bool -> String-saveName side isAI =-  let n = fromEnum side  -- we depend on the numbering hack to number saves-  in (if n > 0-      then "human_" ++ show n-      else "computer_" ++ show (-n))-     ++ if isAI then ".ai.sav" else ".ui.sav"
− Game/LambdaHack/Client/Action/ActionType.hs 
@@ -1,92 +0,0 @@-{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving,-             MultiParamTypeClasses #-}--- | The main game action monad type implementation. Just as any other--- component of the library, this implementation can be substituted.--- This module should not be imported anywhere except in 'Action'--- to expose the executor to any code using the library.-module Game.LambdaHack.Client.Action.ActionType-  ( ActionCli, executorCli-  ) where--import Control.Applicative-import Control.Concurrent.STM-import qualified Control.Monad.IO.Class as IO-import Control.Monad.Trans.State.Strict hiding (State)-import Data.Maybe-import System.FilePath--import Game.LambdaHack.Client.Action.ActionClass-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Animation-import Game.LambdaHack.Common.ClientCmd-import qualified Game.LambdaHack.Common.Save as Save-import Game.LambdaHack.Common.State--data CliState c d = CliState-  { cliState   :: !State             -- ^ current global state-  , cliClient  :: !StateClient       -- ^ current client state-  , cliDict    :: !(ChanServer c d)  -- ^ this client connection information-  , cliToSave  :: !(Save.ChanSave (State, StateClient))-                                     -- ^ connection to the save thread-  , cliSession :: SessionUI          -- ^ UI setup data, empty for AI clients-  }---- | Server state transformation monad.-newtype ActionCli c d a =-    ActionCli {runActionCli :: StateT (CliState c d) IO a}-  deriving (Monad, Functor, Applicative)--instance MonadActionRO (ActionCli c d) where-  getState    = ActionCli $ gets cliState-  getsState f = ActionCli $ gets $ f . cliState--instance MonadAction (ActionCli c d) where-  modifyState f = ActionCli $ state $ \cliS ->-    let newCliS = cliS {cliState = f $ cliState cliS}-    in newCliS `seq` ((), newCliS)-  putState    s = ActionCli $ state $ \cliS ->-    let newCliS = cliS {cliState = s}-    in newCliS `seq` ((), newCliS)--instance MonadClient (ActionCli c d) where-  getClient      = ActionCli $ gets cliClient-  getsClient   f = ActionCli $ gets $ f . cliClient-  modifyClient f = ActionCli $ state $ \cliS ->-    let newCliS = cliS {cliClient = f $ cliClient cliS}-    in newCliS `seq` ((), newCliS)-  putClient    s = ActionCli $ state $ \cliS ->-    let newCliS = cliS {cliClient = s}-    in newCliS `seq` ((), newCliS)-  liftIO         = ActionCli . IO.liftIO-  saveClient     = ActionCli $ do-    s <- gets cliState-    cli <- gets cliClient-    toSave <- gets cliToSave-    IO.liftIO $ Save.saveToChan toSave (s, cli)--instance MonadClientUI (ActionCli c d) where-  getsSession f  = ActionCli $ gets $ f . cliSession--instance MonadClientReadServer c (ActionCli c d) where-  readServer     = ActionCli $ do-    ChanServer{fromServer} <- gets cliDict-    IO.liftIO $ atomically . readTQueue $ fromServer--instance MonadClientWriteServer d (ActionCli c d) where-  writeServer scmd = ActionCli $ do-    ChanServer{toServer} <- gets cliDict-    IO.liftIO $ atomically . writeTQueue toServer $ scmd---- | Init the client, then run an action, with a given session,--- state and history, in the @IO@ monad.-executorCli :: ActionCli c d ()-            -> SessionUI -> State -> StateClient -> ChanServer c d-            -> IO ()-executorCli m cliSession cliState cliClient cliDict =-  let saveFile (_, cli2) =-        fromMaybe "save" (ssavePrefixCli (sdebugCli cli2))-        <.> saveName (sside cli2) (sisAI cli2)-      exe cliToSave =-        evalStateT (runActionCli m) CliState{..}-  in Save.wrapInSaves saveFile exe
− Game/LambdaHack/Client/AtomicSemCli.hs 
@@ -1,767 +0,0 @@--- | Semantics of client UI response to atomic commands.--- See--- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Client.AtomicSemCli-  ( cmdAtomicSem, cmdAtomicSemCli, cmdAtomicFilterCli-  , drawCmdAtomicUI, drawSfxAtomicUI-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Maybe-import Data.Monoid-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.Action-import Game.LambdaHack.Client.Draw-import Game.LambdaHack.Client.HumanLocal-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Animation-import Game.LambdaHack.Common.AtomicCmd-import Game.LambdaHack.Common.AtomicPos-import Game.LambdaHack.Common.AtomicSem-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ActorKind-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.TileKind---- * CmdAtomicAI---- | Clients keep a subset of atomic commands sent by the server--- and add some of their own. The result of this function is the list--- of commands kept for each command received.-cmdAtomicFilterCli :: MonadClient m => CmdAtomic -> m [CmdAtomic]-cmdAtomicFilterCli cmd = case cmd of-  MoveActorA aid _ toP -> do-    cmdSml <- deleteSmell aid toP-    return $ [cmd] ++ cmdSml-  DisplaceActorA source target -> do-    bs <- getsState $ getActorBody source-    bt <- getsState $ getActorBody target-    cmdSource <- deleteSmell source (bpos bt)-    cmdTarget <- deleteSmell target (bpos bs)-    return $ [cmd] ++ cmdSource ++ cmdTarget-  AlterTileA lid p fromTile toTile -> do-    Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops-    lvl <- getLevel lid-    let t = lvl `at` p-    if t == fromTile-      then return [cmd]-      else do-        -- From alterTileA@ we know @t == freshClientTile@,-        -- which is uncanny, so we produce a message.-        -- It happens when a client thinks the tile is @t@,-        -- but it's @fromTile@, and @AlterTileA@ changes it-        -- to @toTile@. See @alterTileA@.-        let subject = ""  -- a hack, we we don't handle adverbs well-            verb = "turn into"-            msg = makeSentence [ "the", MU.Text $ tname $ okind t-                               , "at position", MU.Text $ tshow p-                               , "suddenly"  -- adverb-                               , MU.SubjectVerbSg subject verb-                               , MU.AW $ MU.Text $ tname $ okind toTile ]-        return [ cmd  -- reveal the tile-               , MsgAllA msg  -- show the message-               ]-  SearchTileA aid p fromTile toTile -> do-    b <- getsState $ getActorBody aid-    lvl <- getLevel $ blid b-    let t = lvl `at` p-    return $!-      if t == fromTile-      then -- Fully ignorant. (No intermediate knowledge possible.)-           [ cmd  -- show the message-           , AlterTileA (blid b) p fromTile toTile  -- reveal tile-           ]-      else if t == toTile-           then [cmd]  -- Already knows the tile fully, only confirm.-           else -- Misguided.-                assert `failure` "LoseTile fails to reset memory"-                       `twith` (aid, p, fromTile, toTile, b, t, cmd)-  SpotTileA lid ts -> do-    Kind.COps{cotile} <- getsState scops-    lvl <- getLevel lid-    -- We ignore the server resending us hidden versions of the tiles-    -- (and resending us the same data we already got).-    -- If the tiles are changed to other variants of the hidden tile,-    -- we can still verify by searching, and the UI warns us "obscured".-    let notKnown (p, t) = let tClient = lvl `at` p-                          in t /= tClient-                             && (not (isSecretPos lvl p)-                                 || t /= Tile.hideAs cotile tClient)-        newTs = filter notKnown ts-    return $! if null newTs then [] else [SpotTileA lid newTs]-  AlterSmellA lid p fromSm _toSm -> do-    lvl <- getLevel lid-    let msml = EM.lookup p $ lsmell lvl-    return $ if msml /= fromSm then-               -- Revert to the server smell before server command executes.-               -- This is needed due to our hacky removal of traversed smells-               -- in @deleteSmell@.-               [AlterSmellA lid p msml fromSm, cmd]-             else-               [cmd]-  DiscoverA _ _ iid _ -> do-    disco <- getsClient sdisco-    item <- getsState $ getItemBody iid-    if jkindIx item `EM.member` disco-      then return []-      else return [cmd]-  CoverA _ _ iid _ -> do-    disco <- getsClient sdisco-    item <- getsState $ getItemBody iid-    if jkindIx item `EM.notMember` disco-      then return []-      else return [cmd]-  PerceptionA lid outPer inPer -> do-    -- Here we cheat by setting a new perception outright instead of-    -- in @cmdAtomicSemCli@, to avoid computing perception twice.-    -- TODO: try to assert similar things as for @atomicRemember@:-    -- that posCmdAtomic of all the Lose* commands was visible in old Per,-    -- but is not visible any more.-    perOld <- getPerFid lid-    perceptionA lid outPer inPer-    perNew <- getPerFid lid-    s <- getState-    fid <- getsClient sside-    -- Wipe out actors that just became invisible due to changed FOV.-    -- TODO: perhaps instead create LoseActorA for all actors in lprio,-    -- and keep only those where seenAtomicCli is True; this is even-    -- cheaper than repeated posToActor (until it's optimized).-    let outFov = totalVisible perOld ES.\\ totalVisible perNew-        outPrio = concatMap (\p -> posToActors p lid s) $ ES.elems outFov-        fActor ((aid, b), ais) =-          -- TODO: instead of bproj, check that actor sees himself.-          if not (bproj b) && bfid b == fid-          then Nothing  -- optimization: the actor is soon lost anyway,-                        -- e.g., via DominateActorA, so don't bother-          else Just $ LoseActorA aid b ais-        outActor = mapMaybe fActor outPrio-    -- Wipe out remembered items on tiles that now came into view.-    Level{lfloor, lsmell} <- getLevel lid-    let inFov = totalVisible perNew ES.\\ totalVisible perOld-        pMaybe p = maybe Nothing (\x -> Just (p, x))-        inFloor = mapMaybe (\p -> pMaybe p $ EM.lookup p lfloor)-                           (ES.elems inFov)-        fItem p (iid, k) = LoseItemA iid (getItemBody iid s) k (CFloor lid p)-        fBag (p, bag) = map (fItem p) $ EM.assocs bag-        inItem = concatMap fBag inFloor-    -- Remembered map tiles not wiped out, due to optimization in @spotTileA@.-    -- Wipe out remembered smell on tiles that now came into smell Fov.-    let inSmellFov = smellVisible perNew ES.\\ smellVisible perOld-        inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p lsmell)-                        (ES.elems inSmellFov)-        inSmell = if null inSm then [] else [LoseSmellA lid inSm]-    let seenNew = seenAtomicCli False fid perNew-        seenOld = seenAtomicCli False fid perOld-    -- TODO: these assertions are probably expensive-    psActor <- mapM posCmdAtomic outActor-    -- Verify that we forget only previously seen actors.-    assert (allB seenOld psActor) skip-    -- Verify that we forget only currently invisible actors.-    assert (allB (not . seenNew) psActor) skip-    psItemSmell <- mapM posCmdAtomic $ inItem ++ inSmell-    -- Verify that we forget only previously invisible items and smell.-    assert (allB (not . seenOld) psItemSmell) skip-    -- Verify that we forget only currently seen items and smell.-    assert (allB seenNew psItemSmell) skip-    return $! cmd : outActor ++ inItem ++ inSmell-  _ -> return [cmd]--deleteSmell :: MonadClient m => ActorId -> Point -> m [CmdAtomic]-deleteSmell aid pos = do-  Kind.COps{coactor = Kind.Ops{okind}} <- getsState scops-  b <- getsState $ getActorBody aid-  let canSmell = asmell $ okind $ bkind b-  if canSmell then do-    lvl <- getLevel $ blid b-    let msml = EM.lookup pos $ lsmell lvl-    return $-      maybe [] (\sml -> [AlterSmellA (blid b) pos (Just sml) Nothing]) msml-  else return []---- | Effect of atomic actions on client state is calculated--- in the global state before the command is executed.-cmdAtomicSemCli :: MonadClient m => CmdAtomic -> m ()-cmdAtomicSemCli cmd = case cmd of-  CreateActorA aid body _ -> createActorA aid body-  DestroyActorA aid b _ -> destroyActorA aid b True-  SpotActorA aid body _ -> createActorA aid body-  LoseActorA aid b _ -> destroyActorA aid b False-  LeadFactionA fid source target -> do-    side <- getsClient sside-    when (side == fid) $ do-      mleader <- getsClient _sleader-      assert (mleader == source     -- somebody changed the leader for us-              || mleader == target  -- we changed the leader originally-              `blame` "unexpected leader" `twith` (cmd, mleader)) skip-      modifyClient $ \cli -> cli {_sleader = target}-  DiscoverA lid p iid ik -> discoverA lid p iid ik-  CoverA lid p iid ik -> coverA lid p iid ik-  PerceptionA lid outPer inPer -> perceptionA lid outPer inPer-  RestartA side sdisco sfper _ sdebugCli _ -> do-    shistory <- getsClient shistory-    sconfigUI <- getsClient sconfigUI-    isAI <- getsClient sisAI-    let cli = defStateClient shistory sconfigUI side isAI-    putClient cli { sdisco-                  , sfper-                  -- , sundo = [CmdAtomic cmd]-                  , scurDifficulty = sdifficultyCli sdebugCli-                  , sdebugCli }-  ResumeA _fid sfper -> modifyClient $ \cli -> cli {sfper}-  KillExitA _fid -> killExitA-  SaveBkpA -> saveClient-  _ -> return ()--createActorA :: MonadClient m => ActorId -> Actor -> m ()-createActorA aid _b = do-  let affect tgt = case tgt of-        TEnemyPos a _ _ permit | a == aid -> TEnemy a permit-        _ -> tgt-      affect3 (tgt, mpath) = case tgt of-        TEnemyPos a _ _ permit | a == aid -> (TEnemy a permit, Nothing)-        _ -> (tgt, mpath)-  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}-  modifyClient $ \cli -> cli {scursor = affect $ scursor cli}--destroyActorA :: MonadClient m => ActorId -> Actor -> Bool -> m ()-destroyActorA aid b destroy = do-  when destroy $ modifyClient $ updateTarget aid (const Nothing)  -- gc-  modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli}  -- gc-  let affect tgt = case tgt of-        TEnemy a permit | a == aid -> TEnemyPos a (blid b) (bpos b) permit-          -- Don't consider @destroy@, because even if actor dead, it makes-          -- sense to go to last known location to loot or find others.-        _ -> tgt-      affect3 (tgt, mpath) = (affect tgt, mpath)  -- old path always good-  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}-  modifyClient $ \cli -> cli {scursor = affect $ scursor cli}--perceptionA :: MonadClient m => LevelId -> Perception -> Perception -> m ()-perceptionA lid outPer inPer = do-  -- Clients can't compute FOV on their own, because they don't know-  -- if unknown tiles are clear or not. Server would need to send-  -- info about properties of unknown tiles, which complicates-  -- and makes heavier the most bulky data set in the game: tile maps.-  -- Note we assume, but do not check that @outPer@ is contained-  -- in current perception and @inPer@ has no common part with it.-  -- It would make the already very costly operation even more expensive.-  perOld <- getPerFid lid-  -- Check if new perception is already set in @cmdAtomicFilterCli@-  -- or if we are doing undo/redo, which does not involve filtering.-  -- The data structure is strict, so the cheap check can't be any simpler.-  let interAlready per =-        Just $ totalVisible per `ES.intersection` totalVisible perOld-      unset = maybe False ES.null (interAlready inPer)-              || maybe False (not . ES.null) (interAlready outPer)-  when unset $ do-    let adj Nothing = assert `failure` "no perception to alter" `twith` lid-        adj (Just per) = Just $ addPer (diffPer per outPer) inPer-        f = EM.alter adj lid-    modifyClient $ \cli -> cli {sfper = f (sfper cli)}--discoverA :: MonadClient m-          => LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m ()-discoverA lid p iid ik = do-  item <- getsState $ getItemBody iid-  let f Nothing = Just ik-      f (Just ik2) = assert `failure` "already discovered"-                            `twith` (lid, p, iid, ik, ik2)-  modifyClient $ \cli -> cli {sdisco = EM.alter f (jkindIx item) (sdisco cli)}--coverA :: MonadClient m-       => LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m ()-coverA lid p iid ik = do-  item <- getsState $ getItemBody iid-  let f Nothing = assert `failure` "already covered" `twith` (lid, p, iid, ik)-      f (Just ik2) = assert (ik == ik2 `blame` "unexpected covered item kind"-                                       `twith` (ik, ik2)) Nothing-  modifyClient $ \cli -> cli {sdisco = EM.alter f (jkindIx item) (sdisco cli)}--killExitA :: MonadClient m => m ()-killExitA = modifyClient $ \cli -> cli {squit = True}---- * CmdAtomicUI---- TODO: let user configure which messages are not created, which are--- slightly hidden, which are shown and which flash and center screen--- and perhaps highligh the related location/actor. Perhaps even--- switch to the actor, changing HP displayed on screen, etc.--- but it's too short a clip to read the numbers, so probably--- highlighing should be enough.--- TODO: for a start, flesh out the verbose variant and then add--- a single client debug option that flips verbosity------ | Visualization of atomic actions for the client is perfomed--- in the global state after the command is executed and after--- the client state is modified by the command.-drawCmdAtomicUI :: MonadClientUI m => Bool -> CmdAtomic -> m ()-drawCmdAtomicUI verbose cmd = case cmd of-  CreateActorA aid body _ -> createActorUI aid body verbose "appear"-  DestroyActorA aid body _ -> do-    destroyActorUI aid body "die" "be destroyed" verbose-    side <- getsClient sside-    when (bfid body == side && not (bproj body)) stopPlayBack-  CreateItemA _ item k _ -> itemVerbMU item k "drop to the ground"-  DestroyItemA _ item k _ -> itemVerbMU item k "disappear"-  SpotActorA aid body _ -> createActorUI aid body verbose "be spotted"-  LoseActorA aid body _ ->-    destroyActorUI aid body "be missing in action" "be lost" verbose-  SpotItemA _ item k c -> do-    scursorOld <- getsClient scursor-    case scursorOld of-      TEnemy{} -> return ()  -- probably too important to overwrite-      TEnemyPos{} -> return ()-      _ -> do-        (lid, p) <- posOfContainer c-        modifyClient $ \cli -> cli {scursor = TPoint lid p}-        stopPlayBack-        -- TODO: perhaps don't spam for already seen items; very hard to do-        itemVerbMU item k "be spotted"-  MoveActorA aid _ _ -> lookAtMove aid-  WaitActorA aid _ _| verbose -> aVerbMU aid "wait"-  DisplaceActorA source target -> displaceActorUI source target-  MoveItemA iid k c1 c2 -> moveItemUI verbose iid k c1 c2-  HealActorA aid n -> do-    when verbose $-      aVerbMU aid $ MU.Text $ (if n > 0 then "heal" else "lose")-                              <+> tshow (abs n) <> "HP"-    mleader <- getsClient _sleader-    when (Just aid == mleader) $ do-      Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops-      b <- getsState $ getActorBody aid-      let ActorKind{ahp} = okind $ bkind b-      when (bhp b == maxDice ahp) $ do-        actorVerbMU aid b "heal fully"-        stopPlayBack-  HasteActorA aid delta ->-    aVerbMU aid $ if delta > speedZero-                  then "speed up"-                  else "slow down"-  LeadFactionA fid (Just source) (Just target) -> do-    side <- getsClient sside-    when (fid == side) $ do-      actorD <- getsState sactorD-      case EM.lookup source actorD of-        Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do-          -- Regardless who the leader is, give proper names here, not 'you'.-          tb <- getsState $ getActorBody target-          let subject = partActor tb-              object  = partActor sb-          msgAdd $ makeSentence [ MU.SubjectVerbSg subject "take command"-                                , "from", object ]-        _ -> skip-  DiplFactionA fid1 fid2 _ toDipl -> do-    name1 <- getsState $ gname . (EM.! fid1) . sfactionD-    name2 <- getsState $ gname . (EM.! fid2) . sfactionD-    let showDipl Unknown = "unknown to each other"-        showDipl Neutral = "in neutral diplomatic relations"-        showDipl Alliance = "allied"-        showDipl War = "at war"-    msgAdd $ name1 <+> "and" <+> name2 <+> "are now" <+> showDipl toDipl <> "."-  QuitFactionA fid mbody _ toSt -> quitFactionUI fid mbody toSt-  AlterTileA{} | verbose ->-    return ()  -- TODO: door opens-  SearchTileA aid p fromTile toTile -> do-    Kind.COps{cotile = Kind.Ops{okind}} <- getsState scops-    b <- getsState $ getActorBody aid-    lvl <- getLevel $ blid b-    subject <- partAidLeader aid-    let t = lvl `at` p-        verb | t == toTile = "confirm"-             | otherwise = "reveal"-        subject2 = MU.Text $ tname $ okind fromTile-        verb2 = "be"-    let msg = makeSentence [ MU.SubjectVerbSg subject verb-                           , "that the"-                           , MU.SubjectVerbSg subject2 verb2-                           , "a hidden"-                           , MU.Text $ tname $ okind toTile ]-    msgAdd msg-  AgeGameA t -> do-    when (t > timeClip) $ displayFrames [Nothing]  -- show delay-    -- TODO: shows messages on leader level, instead of recently shown-    -- level (e.g., between animations); perhaps draw messages separately-    -- from level (but on the same text window) or keep last level frame-    -- and only overlay messages on it when needed; or store the level-    -- of last shown-    displayPush  -- TODO: is this really needed? write why-  DiscoverA _ _ iid _ -> do-    disco <- getsClient sdisco-    item <- getsState $ getItemBody iid-    let ix = jkindIx item-    Kind.COps{coitem} <- getsState scops-    let discoUnknown = EM.delete ix disco-        (objUnkown1, objUnkown2) = partItem coitem discoUnknown item-        msg = makeSentence-          [ "the", MU.SubjectVerbSg (MU.Phrase [objUnkown1, objUnkown2])-                                    "turn out to be"-          , partItemAW coitem disco item ]-    msgAdd msg-  CoverA _ _ iid ik -> do-    discoUnknown <- getsClient sdisco-    item <- getsState $ getItemBody iid-    let ix = jkindIx item-    Kind.COps{coitem} <- getsState scops-    let disco = EM.insert ix ik discoUnknown-        (objUnkown1, objUnkown2) = partItem coitem discoUnknown item-        (obj1, obj2) = partItem coitem disco item-        msg = makeSentence-          [ "the", MU.SubjectVerbSg (MU.Phrase [obj1, obj2])-                                    "look like an ordinary"-          , objUnkown1, objUnkown2 ]-    msgAdd msg-  RestartA _ _ _ _ _ t -> msgAdd $ "New game started in" <+> t <+> "mode."-  SaveBkpA | verbose -> msgAdd "Saving backup."-  MsgAllA msg -> msgAdd msg-  _ -> return ()--lookAtMove :: MonadClientUI m => ActorId -> m ()-lookAtMove aid = do-  body <- getsState $ getActorBody aid-  side <- getsClient sside-  tgtMode <- getsClient stgtMode-  when (not (bproj body)-        && bfid body == side-        && isNothing tgtMode) $ do  -- targeting does a more extensive look-    lookMsg <- lookAt False "" True (bpos body) aid ""-    msgAdd lookMsg-  fact <- getsState $ (EM.! bfid body) . sfactionD-  Level{lxsize, lysize} <- getsState $ (EM.! blid body) . sdungeon-  if side == bfid body then do-    foes <- getsState $ actorList (isAtWar fact) (blid body)-    when (foesAdjacent lxsize lysize (bpos body) foes) stopPlayBack-  else when (isAtWar fact side) $ do-    foes <- getsState $ actorNotProjList (== side) (blid body)-    when (foesAdjacent lxsize lysize (bpos body) foes) stopPlayBack---- | Sentences such as \"Dog barks loudly.\".-actorVerbMU :: MonadClientUI m => ActorId -> Actor -> MU.Part -> m ()-actorVerbMU aid b verb = do-  subject <- partActorLeader aid b-  msgAdd $ makeSentence [MU.SubjectVerbSg subject verb]--aVerbMU :: MonadClientUI m => ActorId -> MU.Part -> m ()-aVerbMU aid verb = do-  b <- getsState $ getActorBody aid-  actorVerbMU aid b verb--itemVerbMU :: MonadClientUI m => Item -> Int -> MU.Part -> m ()-itemVerbMU item k verb = assert (k > 0) $ do-  Kind.COps{coitem} <- getsState scops-  disco <- getsClient sdisco-  let subject = partItemWs coitem disco k item-      msg | k > 1 = makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes subject verb]-          | otherwise = makeSentence [MU.SubjectVerbSg subject verb]-  msgAdd msg--_iVerbMU :: MonadClientUI m => ItemId -> Int -> MU.Part -> m ()-_iVerbMU iid k verb = do-  item <- getsState $ getItemBody iid-  itemVerbMU item k verb--aiVerbMU :: MonadClientUI m => ActorId -> MU.Part -> ItemId -> Int -> m ()-aiVerbMU aid verb iid k = do-  Kind.COps{coitem} <- getsState scops-  disco <- getsClient sdisco-  item <- getsState $ getItemBody iid-  subject <- partAidLeader aid-  let msg = makeSentence [ MU.SubjectVerbSg subject verb-                         , partItemWs coitem disco k item ]-  msgAdd msg---- TODO: "XXX spots YYY"? or blink or show the changed cursor?-createActorUI :: MonadClientUI m => ActorId -> Actor -> Bool -> MU.Part -> m ()-createActorUI aid body verbose verb = do-  side <- getsClient sside-  when (verbose || bfid body /= side) $ actorVerbMU aid body verb-  when (bfid body /= side) $ do-    fact <- getsState $ (EM.! bfid body) . sfactionD-    when (not (bproj body) && isAtWar fact side) $ do-      -- Target even if nobody can aim at the enemy. Let's home in on him-      -- and then we can aim or melee. We set permit to False, because it's-      -- technically very hard to check aimability here, because we are-      -- in-between turns and, e.g., leader's move has not yet been taken-      -- into account.-      modifyClient $ \cli -> cli {scursor = TEnemy aid False}-    stopPlayBack-  lookAtMove aid--destroyActorUI :: MonadClientUI m-               => ActorId -> Actor -> MU.Part -> MU.Part -> Bool -> m ()-destroyActorUI aid body verb verboseVerb verbose = do-  side <- getsClient sside-  if (bfid body == side && bhp body <= 0 && not (bproj body)) then do-    actorVerbMU aid body verb-    void $ displayMore ColorBW ""-  else when verbose $ actorVerbMU aid body verboseVerb--moveItemUI :: MonadClientUI m-           => Bool -> ItemId -> Int -> Container -> Container -> m ()-moveItemUI verbose iid k c1 c2 = do-  Kind.COps{coitem} <- getsState scops-  item <- getsState $ getItemBody iid-  disco <- getsClient sdisco-  case (c1, c2) of-    (CFloor _ _, CActor aid l) -> do-      b <- getsState $ getActorBody aid-      unless (bproj b) $ do-        let n = bbag b EM.! iid-        side <- getsClient sside-        if bfid b == side then-          msgAdd $ makePhrase [ letterLabel l-                              , partItemWs coitem disco n item-                              , "\n" ]-        else aiVerbMU aid "pick up" iid k-    (CActor aid _, CFloor _ _) | verbose ->-      aiVerbMU aid "drop" iid k-    _ -> return ()--displaceActorUI :: MonadClientUI m => ActorId -> ActorId -> m ()-displaceActorUI source target = do-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  spart <- partActorLeader source sb-  tpart <- partActorLeader target tb-  let msg = makeSentence [MU.SubjectVerbSg spart "displace", tpart]-  msgAdd msg-  when (bfid sb /= bfid tb) $ do-    lookAtMove source-    lookAtMove target-  let ps = (bpos tb, bpos sb)-  animFrs <- animate (blid sb) $ swapPlaces ps-  displayFrames $ Nothing : animFrs--quitFactionUI :: MonadClientUI m-              => FactionId -> Maybe Actor -> Maybe Status -> m ()-quitFactionUI fid mbody toSt = do-  cops@Kind.COps{coitem=Kind.Ops{okind, ouniqGroup}} <- getsState scops-  fact <- getsState $ (EM.! fid) . sfactionD-  let fidName = MU.Text $ gname fact-      horror = isHorrorFact cops fact-  side <- getsClient sside-  let msgIfSide _ | fid /= side = Nothing-      msgIfSide s = Just s-      (startingPart, partingPart) = case toSt of-        _ | horror ->-          (Nothing, Nothing)  -- Ignore summoned actors' factions.-        Just Status{stOutcome=Killed} ->-          ( Just "be eliminated"-          , msgIfSide "Let's hope another party can save the day!" )-        Just Status{stOutcome=Defeated} ->-          ( Just "be decisively defeated"-          , msgIfSide "Let's hope your new overlords let you live." )-        Just Status{stOutcome=Camping} ->-          ( Just "order save and exit"-          , Just $ if fid == side-                   then "See you soon, stronger and braver!"-                   else "See you soon, stalwart warrior!" )-        Just Status{stOutcome=Conquer} ->-          ( Just "vanquish all foes"-          , msgIfSide "Can it be done in a better style, though?" )-        Just Status{stOutcome=Escape} ->-          ( Just "achieve victory"-          , msgIfSide "Can it be done better, though?" )-        Just Status{stOutcome=Restart, stInfo} ->-          ( Just $ MU.Text $ "order mission restart in" <+> stInfo <+> "mode"-          , Just $ if fid == side-                   then "This time for real."-                   else "Somebody couldn't stand the heat." )-        Nothing ->-          (Nothing, Nothing)  -- Wipe out the quit flag for the savegame files.-  case startingPart of-    Nothing -> return ()-    Just sp -> do-      let msg = makeSentence [MU.SubjectVerbSg fidName sp]-      msgAdd msg-  case (toSt, partingPart) of-    (Just status, Just pp) -> do-      (bag, total) <- case mbody of-        Just body | fid == side -> getsState $ calculateTotal body-        _ -> case gleader fact of-          Nothing -> return (EM.empty, 0)-          Just aid -> do-            b <- getsState $ getActorBody aid-            getsState $ calculateTotal b-      let currencyName = MU.Text $ iname $ okind $ ouniqGroup "currency"-          itemMsg = makeSentence [ "Your loot is worth"-                                 , MU.CarWs total currencyName ]-                    <+> moreMsg-      startingSlide <- promptToSlideshow moreMsg-      recordHistory  -- we are going to exit or restart, so record-      itemSlides <--        if EM.null bag then return mempty-        else do-          io <- floorItemOverlay bag-          overlayToSlideshow itemMsg io-      -- Show score for any UI client, even though it is saved only-      -- for human UI clients.-      scoreSlides <- scoreToSlideshow total status-      partingSlide <- promptToSlideshow $ pp <+> moreMsg-      shutdownSlide <- promptToSlideshow pp-      -- TODO: First ESC cancels items display.-      void $ getInitConfirms ColorFull []-           $ startingSlide <> itemSlides-      -- TODO: Second ESC cancels high score and parting message display.-      -- The last slide stays onscreen during shutdown, etc.-          <> scoreSlides <> partingSlide <> shutdownSlide-    _ -> return ()---- * SfxAtomicUI--drawSfxAtomicUI :: MonadClientUI m => Bool -> SfxAtomic -> m ()-drawSfxAtomicUI verbose sfx = case sfx of-  StrikeD source target item b -> strikeD source target item b-  RecoilD source target _ _ -> do-    spart <- partAidLeader source-    tpart <- partAidLeader target-    msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink away from", tpart]-  ProjectD aid iid -> aiVerbMU aid "aim" iid 1-  CatchD aid iid -> aiVerbMU aid "catch" iid 1-  ActivateD aid iid -> aiVerbMU aid "activate"{-TODO-} iid 1-  CheckD aid iid -> aiVerbMU aid "check" iid 1-  TriggerD aid _p _feat | verbose ->-    aVerbMU aid "trigger"  -- TODO: opens door-  ShunD aid _p _ | verbose ->-    aVerbMU aid "shun"  -- TODO: shuns stairs down-  EffectD aid effect -> do-    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.-      let firstFall | fid == side && bproj b = "fall apart"-                    | fid == side =  "fall down"-                    | bproj b = "break up"-                    | otherwise =  "collapse"-          hurtExtra | fid == side && bproj b = "be stomped flat"-                    | fid == side = "be ground into the floor"-                    | 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) =-            case effect of-              Effect.Hurt _ p | deadPreviousTurn p -> (True, hurtExtra)-              Effect.Heal p | deadPreviousTurn 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-        displayFrames animDie-    else case effect of-        Effect.NoEffect -> msgAdd "Nothing happens."-        Effect.Heal p | p > 0 -> do-          if fid == side then-            actorVerbMU aid b "feel healthier"-          else-            actorVerbMU aid b "look healthier"-          let ps = (bpos b, bpos b)-          animFrs <- animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue-          displayFrames $ Nothing : animFrs-        Effect.Heal _ -> do-          if fid == side then-            actorVerbMU aid b "feel wounded"-          else-            actorVerbMU aid b "look wounded"-          let ps = (bpos b, bpos b)-          animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red-          displayFrames $ Nothing : animFrs-        Effect.Mindprobe nEnemy -> do-          let msg = makeSentence-                [MU.CardinalWs nEnemy "howl", "of anger", "can be heard"]-          msgAdd msg-        Effect.Dominate -> do-          if fid == side then do-            aVerbMU aid $ MU.Text "black out, dominated by foes"-            void $ displayMore ColorFull ""-          else do-            fidName <- getsState $ gname . (EM.! fid) . sfactionD-            aVerbMU aid $ MU.Text $ "be no longer controlled by" <+> fidName-        Effect.ApplyPerfume ->-          msgAdd "The fragrance quells all scents in the vicinity."-        Effect.Searching{} -> do-          subject <- partActorLeader aid b-          let msg = makeSentence-                [ "It gets lost and"-                , MU.SubjectVerbSg subject "search in vain" ]-          msgAdd msg-        Effect.Ascend k | k > 0 -> actorVerbMU aid b "find a way upstairs"-        Effect.Ascend k | k < 0 -> actorVerbMU aid b "find a way downstairs"-        Effect.Ascend{} -> assert `failure` sfx-        _ -> return ()-  MsgFidD _ msg -> msgAdd msg-  MsgAllD msg -> msgAdd msg-  DisplayPushD _ ->-    -- TODO: shows messages on leader level, instead of recently shown-    -- level (e.g., between animations); perhaps draw messages separately-    -- from level (but on the same text window) or keep last level frame-    -- and only overlay messages on it when needed; or store the level-    -- of last shown-    displayPush-  DisplayDelayD _ -> displayFrames [Nothing]-  RecordHistoryD _ -> recordHistory-  _ -> return ()--strikeD :: MonadClientUI m-        => ActorId -> ActorId -> Item -> HitAtomic -> m ()-strikeD source target item b = assert (source /= target) $ do-  Kind.COps{coitem=coitem@Kind.Ops{okind}} <- getsState scops-  disco <- getsClient sdisco-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  spart <- partActorLeader source sb-  tpart <- partActorLeader target tb-  let (verb, withWhat) | bproj sb = ("hit", False)-                       | otherwise =-        case jkind disco item of-          Nothing -> ("hit", False)  -- not identified-          Just ik -> let kind = okind ik-                     in ( iverbApply kind-                        , isNothing $ lookup "hth" $ ifreq kind )-      msg MissBlockD =-        let (partBlock1, partBlock2) =-              if withWhat-              then ("swing", partItemAW coitem disco item)-              else ("try to", verb)-        in makeSentence-          [ MU.SubjectVerbSg spart partBlock1-          , partBlock2 MU.:> ", but"-          , MU.SubjectVerbSg tpart "block"-          ]-      msg _ = makeSentence $-        [MU.SubjectVerbSg spart verb, tpart]-        ++ if withWhat-           then ["with", partItemAW coitem disco item]-           else []-  msgAdd $ msg b-  let ps = (bpos tb, bpos sb)-      anim HitD = twirlSplash ps Color.BrRed Color.Red-      anim HitBlockD = blockHit ps Color.BrRed Color.Red-      anim MissBlockD = blockMiss ps-  animFrs <- animate (blid sb) $ anim b-  displayFrames $ Nothing : animFrs
+ Game/LambdaHack/Client/Bfs.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Breadth first search algorithms.+module Game.LambdaHack.Client.Bfs+  ( -- * Public API+    BfsDistance, MoveLegal(..), apartBfs+  , fillBfs, findPathBfs, accessBfs+    -- * Internal functions+  , minKnownBfs+  ) where++import Control.Arrow (second)+import Control.Exception.Assert.Sugar+import Data.Binary+import Data.Bits (Bits, complement, (.&.), (.|.))+import Data.List+import Data.Maybe+import qualified Data.Sequence as Seq++import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.Vector++-- | Weighted distance between points along shortest paths.+newtype BfsDistance = BfsDistance Word8+  deriving (Show, Eq, Ord, Enum, Bounded, Bits)++-- | State of legality of moves between adjacent points.+data MoveLegal = MoveBlocked | MoveToOpen | MoveToUnknown+  deriving Eq++-- | The minimal distance value assigned to paths that don't enter+-- any unknown tiles.+minKnownBfs :: BfsDistance+minKnownBfs = toEnum $ (1 + fromEnum (maxBound :: BfsDistance)) `div` 2++-- | The distance value that denote no legal path between points.+apartBfs :: BfsDistance+apartBfs = pred minKnownBfs++-- | Fill out the given BFS array.+fillBfs :: (Point -> Point -> MoveLegal)  -- ^ is a move from known tile legal+        -> (Point -> Point -> Bool)       -- ^ is a move from unknown legal+        -> Point                          -- ^ starting position+        -> PointArray.Array BfsDistance   -- ^ initial array, with @apartBfs@+        -> PointArray.Array BfsDistance   -- ^ array with calculated distances+fillBfs isEnterable passUnknown origin aInitial =+  let maxUnknownBfs = pred apartBfs+      maxKnownBfs = pred maxBound+      bfs :: Seq.Seq (Point, BfsDistance)+          -> PointArray.Array BfsDistance+          -> PointArray.Array BfsDistance+      bfs q a =+        case Seq.viewr q of+          Seq.EmptyR -> a  -- no more positions to check+          _ Seq.:> (_, d)+            | d == maxUnknownBfs || d == maxKnownBfs -> a  -- too far+          q1 Seq.:> (pos, oldDistance) | oldDistance >= minKnownBfs ->+            let distance = succ oldDistance+                allMvs = map (shift pos) moves+                freshMv p = a PointArray.! p == apartBfs+                freshMvs = filter freshMv allMvs+                legal p = (p, isEnterable pos p)+                legalities = map legal freshMvs+                notBlocked = filter ((/= MoveBlocked) . snd) legalities+                legalToDist l = if l == MoveToOpen+                                then distance+                                else distance .&. complement minKnownBfs+                mvs = map (second legalToDist) notBlocked+                q2 = foldr (Seq.<|) q1 mvs+                s2 = a PointArray.// mvs+            in bfs q2 s2+          q1 Seq.:> (pos, oldDistance) ->+            let distance = succ oldDistance+                allMvs = map (shift pos) moves+                goodMv p = a PointArray.! p == apartBfs && passUnknown pos p+                mvs = zip (filter goodMv allMvs) (repeat distance)+                q2 = foldr (Seq.<|) q1 mvs+                s2 = a PointArray.// mvs+            in bfs q2 s2+      origin0 = (origin, minKnownBfs)+  in bfs (Seq.singleton origin0) (aInitial PointArray.// [origin0])++-- TODO: Use http://harablog.wordpress.com/2011/09/07/jump-point-search/+-- to determine a few really different paths and compare them,+-- e.g., how many closed doors they pass, open doors, unknown tiles+-- on the path or close enough to reveal them.+-- Also, check if JPS can somehow optimize BFS or pathBfs.+-- | Find a path, without the source position, with the smallest length.+-- The @eps@ coefficient determines which direction (or the closest+-- directions available) that path should prefer, where 0 means north-west+-- and 1 means north.+findPathBfs :: (Point -> Point -> MoveLegal)+            -> (Point -> Point -> Bool)+            -> Point -> Point -> Int -> PointArray.Array BfsDistance+            -> Maybe [Point]+findPathBfs isEnterable passUnknown source target sepsRaw bfs =+  assert (bfs PointArray.! source == minKnownBfs) $+  let targetDist = bfs PointArray.! target+  in if targetDist == apartBfs+     then Nothing+     else+       let eps = sepsRaw `mod` 4+           (mc1, mc2) = splitAt eps movesCardinal+           (md1, md2) = splitAt eps movesDiagonal+           preferredMoves = mc1 ++ reverse mc2 ++ md2 ++ reverse md1  -- fuzz+           track :: Point -> BfsDistance -> [Point] -> [Point]+           track pos oldDist suffix | oldDist == minKnownBfs =+             assert (pos == source+                     `blame` (source, target, pos, suffix)) suffix+           track pos oldDist suffix | oldDist > minKnownBfs =+             let dist = pred oldDist+                 children = map (shift pos) preferredMoves+                 matchesDist p = bfs PointArray.! p == dist+                                 && isEnterable p pos == MoveToOpen+                 minP = fromMaybe (assert `failure` (pos, oldDist, children))+                                  (find matchesDist children)+             in track minP dist (pos : suffix)+           track pos oldDist suffix =+             let distUnknown = pred oldDist+                 distKnown = distUnknown .|. minKnownBfs+                 children = map (shift pos) preferredMoves+                 matchesDistUnknown p = bfs PointArray.! p == distUnknown+                                        && passUnknown p pos+                 matchesDistKnown p = bfs PointArray.! p == distKnown+                                      && isEnterable p pos == MoveToUnknown+                 (minP, dist) = case find matchesDistKnown children of+                   Just p -> (p, distKnown)+                   Nothing -> case find matchesDistUnknown children of+                     Just p -> (p, distUnknown)+                     Nothing -> assert `failure` (pos, oldDist, children)+             in track minP dist (pos : suffix)+       in Just $ track target targetDist []++-- | Access a BFS array and interpret the looked up distance value.+accessBfs :: PointArray.Array BfsDistance -> Point -> Maybe Int+{-# INLINE accessBfs #-}+accessBfs bfs target =+  let dist = bfs PointArray.! target+  in if dist == apartBfs+     then Nothing+     else Just $ fromEnum $ dist .&. complement minKnownBfs
+ Game/LambdaHack/Client/BfsClient.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE TupleSections #-}+-- | Breadth first search and realted algorithms using the client monad.+module Game.LambdaHack.Client.BfsClient+  ( getCacheBfsAndPath, getCacheBfs, accessCacheBfs+  , unexploredDepth, closestUnknown, closestSuspect, closestSmell, furthestKnown+  , closestTriggers, closestItems, closestFoes+  ) where++import Control.Arrow ((&&&))+import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.List+import Data.Maybe+import Data.Ord++import Game.LambdaHack.Client.Bfs+import Game.LambdaHack.Client.CommonClient+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import qualified Game.LambdaHack.Common.Ability as Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.TileKind++-- | Get cached BFS data and path or, if not stored, generate,+-- store and return. Due to laziness, they are not calculated until needed.+getCacheBfsAndPath :: forall m. MonadClient m+                   => ActorId -> Point+                   -> m (PointArray.Array BfsDistance, Maybe [Point])+getCacheBfsAndPath aid target = do+  seps <- getsClient seps+  let pathAndStore :: PointArray.Array BfsDistance+                   -> m (PointArray.Array BfsDistance, Maybe [Point])+      pathAndStore bfs = do+        computePath <- computePathBFS aid+        let mpath = computePath target seps bfs+        modifyClient $ \cli ->+          cli {sbfsD = EM.insert aid (bfs, target, seps, mpath) (sbfsD cli)}+        return (bfs, mpath)+  mbfs <- getsClient $ EM.lookup aid . sbfsD+  case mbfs of+    Just (bfs, targetOld, sepsOld, mpath) | targetOld == target+                                            && sepsOld == seps ->+      return (bfs, mpath)+    Just (bfs, _, _, _) -> pathAndStore bfs+    Nothing -> do+      bfs <- computeBFS aid+      pathAndStore bfs++getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)+{-# INLINE getCacheBfs #-}+getCacheBfs aid = do+  mbfs <- getsClient $ EM.lookup aid . sbfsD+  case mbfs of+    Just (bfs, _, _, _) -> return bfs+    Nothing -> fmap fst $ getCacheBfsAndPath aid (Point 0 0)++computeBFS :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)+computeBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do+  b <- getsState $ getActorBody aid+  Level{lxsize, lysize} <- getLevel $ blid b+  let origin = bpos b+      vInitial = PointArray.replicateA lxsize lysize apartBfs+  -- Here we don't want '$!', because we want the BFS data lazy.+  return ${-keep it!-} fillBfs isEnterable passUnknown origin vInitial++computePathBFS :: MonadClient m+               => ActorId+               -> m (Point -> Int -> PointArray.Array BfsDistance+                     -> Maybe [Point])+computePathBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do+  b <- getsState $ getActorBody aid+  let origin = bpos b+  -- Here we don't want '$!', because we want the BFS data lazy.+  return ${-keep it!-} findPathBfs isEnterable passUnknown origin++computeAnythingBFS :: MonadClient m+                   => ((Point -> Point -> MoveLegal)+                       -> (Point -> Point -> Bool)+                       -> ActorId+                       -> m a)+                   -> ActorId+                   -> m a+computeAnythingBFS fAnything aid = do+  cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops+  b <- getsState $ getActorBody aid+  mleader <- getsClient _sleader+  actorSk <- actorSkillsClient aid mleader  -- TODO: reset BFS at leader change?+  lvl <- getLevel $ blid b+  -- 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 []+      conditions = catMaybes $ chAccess : chDoorAccess+      -- Legality of move from a known tile, assuming doors freely openable.+      isEnterable :: Point -> Point -> MoveLegal+      isEnterable spos tpos =+        let st = lvl `at` spos+            tt = lvl `at` tpos+            allOK = all (\f -> f spos tpos) conditions+        in if tt == unknownId+           then if not (Tile.isSuspect cotile st) && allOK+                then MoveToUnknown+                else MoveBlocked+           else if Tile.isPassable cotile tt+                   && not (Tile.isChangeable cotile st)  -- takes time to change+                   && allOK+                then MoveToOpen+                else MoveBlocked+      -- Legality of move from an unknown tile, assuming unknown are open.+      passUnknown :: Point -> Point -> Bool+      passUnknown = case chAccess of  -- spos is unknown, so not a door+        Nothing -> \_ tpos -> let tt = lvl `at` tpos+                              in tt == unknownId+        Just ch -> \spos tpos -> let tt = lvl `at` tpos+                                 in tt == unknownId+                                    && ch spos tpos+  fAnything isEnterable passUnknown aid++accessCacheBfs :: MonadClient m => ActorId -> Point -> m (Maybe Int)+{-# INLINE accessCacheBfs #-}+accessCacheBfs aid target = do+  bfs <- getCacheBfs aid+  return $! accessBfs bfs target++-- | Furthest (wrt paths) known position.+furthestKnown :: MonadClient m => ActorId -> m Point+furthestKnown aid = do+  bfs <- getCacheBfs aid+  getMaxIndex <- rndToAction $ oneOf [ PointArray.maxIndexA+                                     , PointArray.maxLastIndexA ]+  let furthestPos = getMaxIndex bfs+      dist = bfs PointArray.! furthestPos+  return $! if dist <= apartBfs+            then assert `failure` (aid, furthestPos, dist)+            else furthestPos++-- | Closest reachable unknown tile position, if any.+closestUnknown :: MonadClient m => ActorId -> m (Maybe Point)+closestUnknown aid = do+  bfs <- getCacheBfs aid+  getMinIndex <- rndToAction $ oneOf [ PointArray.minIndexA+                                     , PointArray.minLastIndexA ]+  let closestPos = getMinIndex bfs+      dist = bfs PointArray.! closestPos+  if dist >= apartBfs then do+    body <- getsState $ getActorBody aid+    lvl <- getLevel $ blid body+    when (lclear lvl == lseen lvl) $ do  -- explored fully, mark it once for all+      assert (lclear lvl >= lseen lvl) skip+      modifyClient $ \cli ->+        cli {sexplored = ES.insert (blid body) (sexplored cli)}+    return Nothing+  else return $ Just closestPos++-- TODO: this is costly, because target has to be changed every+-- turn when walking along trail. But inverting the sort and going+-- to the newest smell, while sometimes faster, may result in many+-- actors following the same trail, unless we wipe the trail as soon+-- as target is assigned (but then we don't know if we should keep the target+-- or not, because somebody already followed it). OTOH, trails are not+-- common and so if wiped they can't incur a large total cost.+-- TODO: remove targets where the smell is likely to get too old by the time+-- the actor gets there.+-- | Finds smells closest to the actor, except under the actor.+closestSmell :: MonadClient m => ActorId -> m [(Int, (Point, Tile.SmellTime))]+closestSmell aid = do+  body <- getsState $ getActorBody aid+  Level{lsmell} <- getLevel $ blid body+  let smells = EM.assocs lsmell+  case smells of+    [] -> return []+    _ -> do+      bfs <- getCacheBfs aid+      let ts = mapMaybe (\x@(p, _) -> fmap (,x) (accessBfs bfs p)) smells+          ds = filter (\(d, _) -> d /= 0) ts  -- bpos of aid+      return $! sortBy (comparing (fst &&& absoluteTimeNegate . snd . snd)) ds++-- | Closest (wrt paths) suspect tile.+closestSuspect :: MonadClient m => ActorId -> m [Point]+closestSuspect aid = do+  Kind.COps{cotile} <- getsState scops+  body <- getsState $ getActorBody aid+  lvl <- getLevel $ blid body+  let f :: [Point] -> Point -> Kind.Id TileKind -> [Point]+      f acc p t = if Tile.isSuspect cotile t then p : acc else acc+      suspect = PointArray.ifoldlA f [] $ ltile lvl+  case suspect of+    [] -> do+      -- If the level has inaccessible open areas (at least from some stairs)+      -- here finally mark it explored, to enable transition to other levels.+      -- We should generally avoid such levels, because digging and/or trying+      -- to find other stairs leading to disconnected areas is not KISS+      -- so we don't do this in AI, so AI is at a disadvantage.+      modifyClient $ \cli ->+        cli {sexplored = ES.insert (blid body) (sexplored cli)}+      return []+    _ -> do+      bfs <- getCacheBfs aid+      let ds = mapMaybe (\p -> fmap (,p) (accessBfs bfs p)) suspect+      return $! map snd $ sortBy (comparing fst) ds++-- TODO: We assume linear dungeon in @unexploredD@,+-- because otherwise we'd need to calculate shortest paths in a graph, etc.+-- | Closest (wrt paths) triggerable open tiles.+-- The second argument can ever be true only if there's+-- no escape from the dungeon.+closestTriggers :: MonadClient m => Maybe Bool -> Bool -> ActorId -> m [Point]+closestTriggers onlyDir exploredToo aid = do+  Kind.COps{cotile} <- getsState scops+  body <- getsState $ getActorBody aid+  lvl <- getLevel $ blid body+  dungeon <- getsState sdungeon+  explored <- getsClient sexplored+  unexploredD <- unexploredDepth+  let allExplored = ES.size explored == EM.size dungeon+      unexUp = onlyDir /= Just False && unexploredD 1 (blid body)+      unexDown = onlyDir /= Just True && unexploredD (-1) (blid body)+      unexEffect (Effect.Ascend p) = if p > 0 then unexUp else unexDown+      unexEffect _ =+        -- Escape (or guard) only after exploring, for high score, etc.+        allExplored+      isTrigger+        | exploredToo = \t -> Tile.isWalkable cotile t+                              && not (null $ Tile.causeEffects cotile t)+        | otherwise = \t -> Tile.isWalkable cotile t+                            && any unexEffect (Tile.causeEffects cotile t)+      f :: [Point] -> Point -> Kind.Id TileKind -> [Point]+      f acc p t = if isTrigger t then p : acc else acc+  let triggersAll = PointArray.ifoldlA f [] $ ltile lvl+      -- Don't target stairs under the actor. Most of the time they+      -- are blocked and stay so, so we seek other stairs, if any.+      -- If no other stairs in this direction, let's wait here.+      triggers | length triggersAll > 1 = delete (bpos body) triggersAll+               | otherwise = triggersAll+  case triggers of+    [] -> return []+    _ -> do+      bfs <- getCacheBfs aid+      let ds = mapMaybe (\p -> fmap (,p) (accessBfs bfs p)) triggers+      return $! map snd $ sortBy (comparing fst) ds++unexploredDepth :: MonadClient m => m (Int -> LevelId -> Bool)+unexploredDepth = do+  dungeon <- getsState sdungeon+  explored <- getsClient sexplored+  let allExplored = ES.size explored == EM.size dungeon+      unexploredD p =+        let unex lid = allExplored && lescape (dungeon EM.! lid)+                       || ES.notMember lid explored+                       || unexploredD p lid+        in any unex . ascendInBranch dungeon p+  return unexploredD++-- | Closest (wrt paths) items and changeable tiles (e.g., item caches).+closestItems :: MonadClient m => ActorId -> m ([(Int, (Point, Maybe ItemBag))])+closestItems aid = do+  Kind.COps{cotile} <- getsState scops+  body <- getsState $ getActorBody aid+  lvl@Level{lfloor} <- getLevel $ blid body+  let items = EM.assocs lfloor+      f :: [Point] -> Point -> Kind.Id TileKind -> [Point]+      f acc p t = if Tile.isChangeable cotile t then p : acc else acc+      changeable = PointArray.ifoldlA f [] $ ltile lvl+  if null items && null changeable then return []+  else do+    bfs <- getCacheBfs aid+    let is = mapMaybe (\(p, bag) ->+                        fmap (, (p, Just bag)) (accessBfs bfs p)) items+        cs = mapMaybe (\p ->+                        fmap (, (p, Nothing)) (accessBfs bfs p)) changeable+    return $! sortBy (comparing fst) $ is ++ cs++-- | Closest (wrt paths) enemy actors.+closestFoes :: MonadClient m+            => [(ActorId, Actor)] -> ActorId -> m [(Int, (ActorId, Actor))]+closestFoes foes aid = do+  case foes of+    [] -> return []+    _ -> do+      bfs <- getCacheBfs aid+      let ds = mapMaybe (\x@(_, b) -> fmap (,x) (accessBfs bfs (bpos b))) foes+      return $! sortBy (comparing fst) ds
− Game/LambdaHack/Client/Binding.hs 
@@ -1,112 +0,0 @@--- | Binding of keys to commands.--- No operation in this module involves the 'State' or 'Action' type.-module Game.LambdaHack.Client.Binding-  ( Binding(..), stdBinding, keyHelp,-  ) where--import Control.Arrow (second)-import qualified Data.Char as Char-import Data.List-import qualified Data.Map.Strict as M-import Data.Text (Text)-import qualified Data.Text as T-import Data.Tuple (swap)--import Game.LambdaHack.Client.Config-import Game.LambdaHack.Common.HumanCmd-import qualified Game.LambdaHack.Common.Key as K-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Content.RuleKind---- | Bindings and other information about human player commands.-data Binding = Binding-  { bcmdMap  :: !(M.Map K.KM (Text, CmdCategory, HumanCmd))-                                        -- ^ binding of keys to commands-  , bcmdList :: ![(K.KM, (Text, CmdCategory, HumanCmd))]-                                        -- ^ the properly ordered list-                                        --   of commands for the help menu-  , brevMap  :: !(M.Map HumanCmd K.KM)  -- ^ and from commands to their keys-  }---- | Binding of keys to movement and other standard commands,--- as well as commands defined in the config file.-stdBinding :: Kind.Ops RuleKind  -- ^ default game rules-           -> ConfigUI           -- ^ game config-           -> Binding            -- ^ concrete binding-stdBinding corule !ConfigUI{configCommands} =-  let stdRuleset = Kind.stdRuleset corule-      heroSelect k = ( K.KM { key=K.Char (Char.intToDigit k)-                            , modifier=K.NoModifier }-                     , (CmdMeta, PickLeader k) )-      cmdWithHelp = rhumanCommands stdRuleset ++ configCommands-      cmdAll =-        cmdWithHelp-        ++ [(K.mkKM "KP_Begin", (CmdMove, Wait))]-        ++ K.moveBinding (\v -> (CmdMove, Move v)) (\v -> (CmdMove, Run v))-        ++ fmap heroSelect [0..9]-      mkDescribed (cat, cmd) = (cmdDescription cmd, cat, cmd)-  in Binding-  { bcmdMap = M.fromList $ map (second mkDescribed) cmdAll-  , bcmdList = map (second mkDescribed) cmdWithHelp-  , brevMap = M.fromList $ map swap $ map (second snd) cmdAll-  }---- | Produce a set of help screens from the key bindings.-keyHelp :: Binding -> Slideshow-keyHelp Binding{bcmdList} =-  let-    movBlurb =-      [ "Move throughout the level with numerical keypad or"-      , "the Vi text editor keys (also known as \"Rogue-like keys\"):"-      , ""-      , "               7 8 9          y k u"-      , "                \\|/            \\|/"-      , "               4-5-6          h-.-l"-      , "                /|\\            /|\\"-      , "               1 2 3          b j n"-      , ""-      , "Run ahead, until anything disturbs you, with SHIFT (or CTRL) and a key."-      , "Press keypad '5' or '.' to wait a turn, bracing for blows next turn."-      , "In targeting mode the same keys move the targeting cursor."-      , ""-      , "Search, open and attack, by bumping into walls, doors and enemies."-      , ""-      , "Press SPACE to see detailed command descriptions."-      ]-    categoryBlurb =-      [ ""-      , "Press SPACE to see the next page of command descriptions."-      ]-    lastBlurb =-      [ ""-      , "For more playing instructions see file PLAYING.md."-      , "Press SPACE to clear the messages and see the map again."-      ]-    fmt k h = T.justifyRight 72 ' '-              $ T.justifyLeft 15 ' ' k-                <> T.justifyLeft 41 ' ' h-    fmts s = " " <> T.justifyLeft 71 ' ' s-    movText = map fmts movBlurb-    categoryText = map fmts categoryBlurb-    lastText = map fmts lastBlurb-    keyCaption = fmt "keys" "command"-    coImage :: K.KM -> [K.KM]-    coImage k = k : sort [ from-                         | (from, (_, _, Macro _ [to])) <- bcmdList-                         , K.mkKM to == k ]-    disp k = T.concat $ intersperse " and " $ map K.showKM $ coImage k-    keys cat = [ fmt (disp k) h-               | (k, (h, cat', _)) <- bcmdList, cat == cat', h /= "" ]-  in toSlideshow True-    [ ["Basic keys. [press SPACE to advance]"] ++ [""]-      ++ movText ++ [moreMsg]-    , [categoryDescription CmdMove <> ". [press SPACE to advance]"] ++ [""]-      ++ [keyCaption] ++ keys CmdMove ++ categoryText ++ [moreMsg]-    , [categoryDescription CmdItem <> ". [press SPACE to advance]"] ++ [""]-      ++ [keyCaption] ++ keys CmdItem ++ categoryText ++ [moreMsg]-    , [categoryDescription CmdTgt <> ". [press SPACE to advance]"] ++ [""]-      ++ [keyCaption] ++ keys CmdTgt ++ categoryText ++ [moreMsg]-    , [categoryDescription CmdMeta <> "."] ++ [""]-      ++ [keyCaption] ++ keys CmdMeta ++ lastText-    ]
− Game/LambdaHack/Client/ClientSem.hs 
@@ -1,325 +0,0 @@--- | Semantics of most 'CmdClientAI' client commands.-module Game.LambdaHack.Client.ClientSem where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Ord-import qualified Data.Text as T--import Game.LambdaHack.Client.Action-import Game.LambdaHack.Client.Binding-import Game.LambdaHack.Client.Config-import Game.LambdaHack.Client.Draw-import Game.LambdaHack.Client.HumanSem-import Game.LambdaHack.Client.RunAction-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.Strategy-import Game.LambdaHack.Client.StrategyAction-import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.HumanCmd-import qualified Game.LambdaHack.Common.Key as K-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.ServerCmd-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.FactionKind-import Game.LambdaHack.Utils.Frequency--queryAI :: MonadClient m => ActorId -> m CmdTakeTimeSer-queryAI oldAid = do-  Kind.COps{cotile, cofaction=Kind.Ops{okind}} <- getsState scops-  oldBody <- getsState $ getActorBody oldAid-  let side = bfid oldBody-      arena = blid oldBody-  fact <- getsState $ (EM.! side) . sfactionD-  lvl <- getLevel arena-  let leaderStuck = waitedLastTurn oldBody-      t = lvl `at` bpos oldBody-      abilityLeader = fAbilityLeader $ okind $ gkind fact-      abilityOther = fAbilityOther $ okind $ gkind fact-  mleader <- getsClient _sleader-  ours <- getsState $ actorNotProjAssocs (== side) arena-  let pickOld = do-        void $ refreshTarget oldAid (oldAid, oldBody)-        queryAIPick (oldAid, oldBody)-  case ours of-    _ | -- Keep the leader: only a leader is allowed to pick another leader.-        mleader /= Just oldAid-        -- Keep the leader: abilities are the same (we assume leader can do-        -- at least as much as others). TODO: check not accurate,-        -- instead define 'movesThisTurn' and use elsehwere.-        || abilityLeader == abilityOther-        -- Keep the leader: spawners can't change leaders themselves.-        || isSpawnFact fact-        -- Keep the leader: he is on stairs and not stuck-        -- and we don't want to clog stairs or get pushed to another level.-        || not leaderStuck && Tile.isStair cotile t-      -> pickOld-    [] -> assert `failure` (oldAid, oldBody)-    [_] -> pickOld  -- Keep the leader: he is alone on the level.-    (captain, captainBody) : (sergeant, sergeantBody) : _ -> do-      -- At this point we almost forget who the old leader was-      -- and treat all party actors the same, eliminating candidates-      -- until we can't distinguish them any more, at which point we prefer-      -- the old leader, if he is among the best candidates-      -- (to make the AI appear more human-like to easier to observe).-      -- TODO: this also takes melee into account, not shooting.-      oursTgt <- fmap catMaybes $ mapM (refreshTarget oldAid) ours-      let targetTEnemy (_, (TEnemy{}, _)) = True-          targetTEnemy _ = False-          (oursTEnemy, oursOther) = partition targetTEnemy oursTgt-          -- These are not necessarily stuck (perhaps can go around),-          -- but their current path is blocked by friends.-          targetBlocked our@((_aid, _b), (_tgt, (path, _etc))) =-            let next = case path of-                  [] -> assert `failure` our-                  [_goal] -> Nothing-                  _ : q : _ -> Just q-            in any ((== next) . Just . bpos . snd) ours--- TODO: stuck actors are picked while others close could approach an enemy;--- we should detect stuck actors (or one-sided stuck)--- so far we only detect blocked and only in Other mode---             && not (aid == oldAid && waitedLastTurn b time)  -- not stuck--- this only prevents staying stuck-          (oursBlocked, oursPos) = partition targetBlocked oursOther-          valueOurs :: ((ActorId, Actor), (Target, PathEtc))-                    -> (Int, Int, Bool)-          valueOurs our@((aid, b), (TEnemy{}, (_, (_, d)))) =-            -- TODO: take weapon, walk and fight speed, etc. into account-            ( d + if targetBlocked our then 2 else 0  -- possible delay, hacky-            , - 10 * (bhp b `div` 10)-            , aid /= oldAid )-          valueOurs ((aid, b), (_tgt, (_path, (goal, d)))) =-            -- Keep proper formation, not too dense, not to sparse.-            let -- TODO: vary the parameters according to the stage of game,-                -- enough equipment or not, game mode, level map, etc.-                minSpread = 7-                maxSpread = 12 * 2-                dcaptain p =-                  chessDistVector $ displacement p (bpos captainBody)-                dsergeant p =-                  chessDistVector $ displacement p (bpos sergeantBody)-                minDist | aid == captain = dsergeant (bpos b)-                        | aid == sergeant = dcaptain (bpos b)-                        | otherwise = dsergeant (bpos b)-                                      `min` dcaptain (bpos b)-                pDist p = dcaptain p + dsergeant p-                sumDist = pDist (bpos b)-                -- Positive, if the goal gets us closer to the party.-                diffDist = sumDist - pDist goal-                minCoeff | minDist < minSpread =-                  (minDist - minSpread) `div` 3-                  - if aid == oldAid then 3 else 0-                         | otherwise = 0-                explorationValue = diffDist * (sumDist `div` 4)--- TODO: this half is not yet ready:--- instead spread targets between actors; moving many actors--- to a single target and stopping and starting them--- is very wasteful; also, pick targets not closest to the actor in hand,--- but to the sum of captain and sergant or something-                sumCoeff | sumDist > maxSpread = - explorationValue-                         | otherwise = 0-            in ( if d == 0 then d-                 else max 1 $ minCoeff + if d < 10-                                         then 3 + d `div` 4-                                         else 9 + d `div` 10-               , sumCoeff-               , aid /= oldAid )-          sortOurs = sortBy $ comparing valueOurs-          goodGeneric _our@((aid, b), (_tgt, _pathEtc)) =-            bhp b > 0  -- not incapacitated-            && not (aid == oldAid && waitedLastTurn b)  -- not stuck-          goodTEnemy our@((_aid, b), (_tgt, (_path, (goal, _d)))) =-            not (adjacent (bpos b) goal) -- not in melee range already-            && goodGeneric our-          oursTEnemyGood = filter goodTEnemy oursTEnemy-          oursPosGood = filter goodGeneric oursPos-          oursBlockedGood = filter goodGeneric oursBlocked-          candidates = sortOurs oursTEnemyGood-                       ++ sortOurs oursPosGood-                       ++ sortOurs oursBlockedGood-      case candidates of-        [] -> queryAIPick (oldAid, oldBody)-        c : _ -> do-          let best = takeWhile ((== valueOurs c) . valueOurs) candidates-              freq = uniformFreq "candidates for AI leader" best-          ((aid, b), _) <- rndToAction $ frequency freq-          s <- getState-          modifyClient $ updateLeader aid s-          queryAIPick (aid, b)--refreshTarget :: MonadClient m-              => ActorId -> (ActorId, Actor)-              -> m (Maybe ((ActorId, Actor), (Target, PathEtc)))-refreshTarget oldLeader (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-  tgtMPath <--    if nullStrategy stratTarget then-      -- No sensible target, wipe out the old one  .-      return Nothing-    else do-      -- Choose a target from those proposed by AI for the actor.-      (tgt, path) <- rndToAction $ frequency $ bestVariant stratTarget-      return $ Just (tgt, Just path)-  let _debug = T.unpack-          $ "\nHandleAI symbol:"    <+> tshow (bsymbol body)-          <> ", aid:"               <+> tshow aid-          <> ", pos:"               <+> tshow (bpos body)-          <> "\nHandleAI starget:"  <+> tshow stratTarget-          <> "\nHandleAI target:"   <+> tshow tgtMPath---  trace _debug skip-  modifyClient $ \cli ->-    cli {stargetD = EM.alter (const $ tgtMPath) aid (stargetD cli)}-  return $! case tgtMPath of-    Just (tgt, Just pathEtc) -> Just ((aid, body), (tgt, pathEtc))-    _ -> Nothing--queryAIPick :: MonadClient m => (ActorId, Actor) -> m CmdTakeTimeSer-queryAIPick (aid, body) = do-  side <- getsClient sside-  assert (bfid body == side `blame` "AI tries to move enemy actor"-                            `twith` (aid, bfid body, side)) skip-  assert (not (bproj body) `blame` "AI gets to manually move its projectiles"-                           `twith` (aid, bfid body, side)) skip-  stratAction <- actionStrategy aid-  -- Run the AI: chose an action from those given by the AI strategy.-  rndToAction $ frequency $ bestVariant stratAction---- | Handle the move of a UI player.-queryUI :: MonadClientUI m => ActorId -> m CmdSer-queryUI aid = do-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  -- When running, stop if disturbed. If not running, let the human-  -- player issue commands, until any command takes time.-  leader <- getLeaderUI-  assert (leader == aid `blame` "player moves not his leader"-                        `twith` (leader, aid)) skip-  srunning <- getsClient srunning-  case srunning of-    Nothing -> humanCommand Nothing-    Just RunParams{runMembers} | isSpawnFact fact && runMembers /= [aid] -> do-      stopRunning-      ConfigUI{configRunStopMsgs} <- getsClient sconfigUI-      let msg = if configRunStopMsgs-                then Just $ "Run stop: spawner leader change"-                else Nothing-      humanCommand msg-    Just runParams -> do-      runOutcome <- continueRun runParams-      case runOutcome of-        Left stopMsg -> do-          stopRunning-          ConfigUI{configRunStopMsgs} <- getsClient sconfigUI-          let msg = if configRunStopMsgs-                    then Just $ "Run stop:" <+> stopMsg-                    else Nothing-          humanCommand msg-        Right (paramNew, runCmd) -> do-          modifyClient $ \cli -> cli {srunning = Just paramNew}-          return $! CmdTakeTimeSer runCmd---- | Determine and process the next human player command. The argument is--- the last stop message due to running, if any.-humanCommand :: forall m. MonadClientUI m-             => Maybe Msg-             -> m CmdSer-humanCommand msgRunStop = do-  -- For human UI we invalidate whole @sbfsD@ at the start of each-  -- UI player input, which is an overkill, but doesn't affects-  -- screensavers, because they are UI, but not human.-  modifyClient $ \cli -> cli {sbfsD = EM.empty}-  let loop :: Maybe (Bool, Overlay) -> m CmdSer-      loop mover = do-        (lastBlank, over) <- case mover of-          Nothing -> do-            -- Display current state if no slideshow or if interrupted.-            modifyClient $ \cli -> cli {slastKey = Nothing}-            sli <- promptToSlideshow ""-            return (False, head . snd $! slideshow sli)-          Just bLast ->-            -- (Re-)display the last slide while waiting for the next key.-            return bLast-        (seqCurrent, seqPrevious, k) <- getsClient slastRecord-        case k of-          0 -> do-            let slastRecord = ([], seqCurrent, 0)-            modifyClient $ \cli -> cli {slastRecord}-          _ -> do-            let slastRecord = ([], seqCurrent ++ seqPrevious, k - 1)-            modifyClient $ \cli -> cli {slastRecord}-        km <- getKeyOverlayCommand lastBlank over-        -- Messages shown, so update history and reset current report.-        recordHistory-        abortOrCmd <- do-          -- Look up the key.-          Binding{bcmdMap} <- askBinding-          case M.lookup km bcmdMap of-            Just (_, _, cmd) -> do-              -- Query and clear the last command key.-              lastKey <- getsClient slastKey-              stgtMode <- getsClient stgtMode-              modifyClient $ \cli -> cli-                {swaitTimes = if swaitTimes cli > 0-                              then - swaitTimes cli-                              else 0}-              if Just km == lastKey-                 || km == K.escKey && isNothing stgtMode && isJust mover-                then do-                  modifyClient $ \cli -> cli {slastKey = Nothing}-                  cmdHumanSem Clear-                else do-                  modifyClient $ \cli -> cli {slastKey = Just km}-                  cmdHumanSem cmd-            Nothing -> let msgKey = "unknown command <" <> K.showKM km <> ">"-                       in fmap Left $ promptToSlideshow msgKey-        -- The command was failed or successful and if the latter,-        -- possibly took some time.-        case abortOrCmd of-          Right cmdS -> do-            -- Exit the loop and let other actors act. No next key needed-            -- and no slides could have been generated.-            modifyClient $ \cli -> cli {slastKey = Nothing}-            case cmdS of-              CmdTakeTimeSer cmd ->-                modifyClient $ \cli -> cli {slastCmd = Just cmd}-              _ -> return ()-            return cmdS-          Left slides -> do-            -- If no time taken, rinse and repeat.-            -- Analyse the obtained slides.-            let (onBlank, sli) = slideshow slides-            mLast <- case reverse sli  of-              [] -> return Nothing-              [sLast] -> return $ Just (onBlank, sLast)-              sls@(sLast : _) -> do-                -- Show, one by one, all slides, awaiting confirmation-                -- for all but the last one.-                -- Note: the code that generates the slides is responsible-                -- for inserting the @more@ prompt.-                go <- getInitConfirms ColorFull [km]-                      $ toSlideshow onBlank $ reverse $ map overlay sls-                return $! if go then Just (onBlank, sLast) else Nothing-            loop mLast-  case msgRunStop of-    Nothing -> loop Nothing-    Just msg -> do-      sli <- promptToSlideshow msg-      loop $ Just (False, head . snd $ slideshow sli)
+ Game/LambdaHack/Client/CommonClient.hs view
@@ -0,0 +1,243 @@+{-# LANGUAGE DataKinds #-}+-- | Common client monad operations.+module Game.LambdaHack.Client.CommonClient+  ( getPerFid, aidTgtToPos, aidTgtAims, makeLine+  , partAidLeader, partActorLeader, partPronounLeader+  , actorSkillsClient, updateItemSlot, fullAssocsClient, activeItemsClient+  , itemToFullClient, pickWeaponClient, sumOrganEqpClient, getModeClient+  ) where++import Control.Exception.Assert.Sugar+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++import Game.LambdaHack.Client.ItemSlot+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import qualified Game.LambdaHack.Common.Ability as Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ModeKind++-- | 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++-- | 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.+partActorLeader :: MonadClient m => ActorId -> Actor -> m MU.Part+partActorLeader aid b = do+  mleader <- getsClient _sleader+  return $! case mleader of+    Just leader | aid == leader -> "you"+    _ -> partActor b++-- | The part of speech with the actor's pronoun or "you" if a leader+-- of the client's faction. The actor may be not present in the dungeon.+partPronounLeader :: MonadClient m => ActorId -> Actor -> m MU.Part+partPronounLeader aid b = do+  mleader <- getsClient _sleader+  return $! case mleader of+    Just leader | aid == leader -> "you"+    _ -> partPronoun b++-- | The part of speech describing the actor (designated by actor id+-- and present in the dungeon) or a special name if a leader+-- of the observer's faction.+partAidLeader :: MonadClient m => ActorId -> m MU.Part+partAidLeader aid = do+  b <- getsState $ getActorBody aid+  partActorLeader aid b++-- | Calculate the position of an actor's target.+aidTgtToPos :: MonadClient m+            => ActorId -> LevelId -> Maybe Target -> m (Maybe Point)+aidTgtToPos aid lidV tgt =+  case tgt of+    Just (TEnemy a _) -> do+      body <- getsState $ getActorBody a+      return $! if blid body == lidV+                then Just (bpos body)+                else Nothing+    Just (TEnemyPos _ lid p _) ->+      return $! if lid == lidV then Just p else Nothing+    Just (TPoint lid p) ->+      return $! if lid == lidV then Just p else Nothing+    Just (TVector v) -> do+      b <- getsState $ getActorBody aid+      Level{lxsize, lysize} <- getLevel lidV+      let shifted = shiftBounded lxsize lysize (bpos b) v+      return $! if shifted == bpos b && v /= Vector 0 0+                then Nothing+                else Just shifted+    Nothing -> do+      scursor <- getsClient scursor+      aidTgtToPos aid lidV $ Just scursor++-- | Check whether one is permitted to aim at a target+-- (this is only checked for actors; positions let player+-- shoot at obstacles, e.g., to destroy them).+-- This assumes @aidTgtToPos@ does not return @Nothing@.+-- Returns a different @seps@, if needed to reach the target actor.+--+-- Note: Perception is not enough for the check,+-- because the target actor can be obscured by a glass wall+-- or be out of sight range, but in weapon range.+aidTgtAims :: MonadClient m+           => ActorId -> LevelId -> Maybe Target -> m (Either Text Int)+aidTgtAims aid lidV tgt = do+  oldEps <- getsClient seps+  case tgt of+    Just (TEnemy a _) -> do+      body <- getsState $ getActorBody a+      let pos = bpos body+      b <- getsState $ getActorBody aid+      if blid b == lidV then do+        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+    Nothing -> do+      scursor <- getsClient scursor+      aidTgtAims aid lidV $ Just scursor++-- | Counts the number of steps until the projectile would hit+-- 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+  cops@Kind.COps{cotile=Kind.Ops{ouniqGroup}} <- getsState scops+  lvl@Level{lxsize, lysize} <- getLevel (blid body)+  bs <- getsState $ filter (not . bproj)+                    . actorList (const True) (blid body)+  let unknownId = ouniqGroup "unknown space"+      dist = chessDist (bpos body) fpos+      calcScore eps = case bla lxsize lysize eps (bpos body) fpos of+        Just bl ->+          let blDist = take dist bl+              blZip = zip (bpos body : blDist) blDist+              noActor p = all ((/= p) . bpos) bs || p == fpos+              accessU = all noActor blDist+                        && all (uncurry $ accessibleUnknown cops lvl) blZip+              nUnknown = length $ filter ((== unknownId) . (lvl `at`)) blDist+          in if accessU then - nUnknown else minBound+        Nothing -> assert `failure` (body, fpos, epsOld)+      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)++actorSkillsClient :: MonadClient m+                  => ActorId -> Maybe ActorId -> m Ability.Skills+actorSkillsClient aid mleader = do+  activeItems <- activeItemsClient aid+  getsState $ actorSkills aid mleader 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+      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++fullAssocsClient :: MonadClient m+                 => ActorId -> [CStore] -> m [(ItemId, ItemFull)]+fullAssocsClient aid cstores = do+  cops <- getsState scops+  disco <- getsClient sdisco+  discoAE <- getsClient sdiscoAE+  getsState $ fullAssocs cops disco discoAE aid cstores++activeItemsClient :: MonadClient m => ActorId -> m [ItemFull]+activeItemsClient aid = do+  activeAssocs <- fullAssocsClient aid [CEqp, COrgan]+  return $! map snd activeAssocs++itemToFullClient :: MonadClient m => m (ItemId -> Int -> ItemFull)+itemToFullClient = do+  cops <- getsState scops+  disco <- getsClient sdisco+  discoAE <- getsClient sdiscoAE+  s <- getState+  let itemToF iid = itemToFull cops disco discoAE iid (getItemBody iid s)+  return itemToF++-- 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]+pickWeaponClient source target = do+  eqpAssocs <- fullAssocsClient source [CEqp]+  bodyAssocs <- fullAssocsClient source [COrgan]+  mleader <- getsClient _sleader+  actorSk <- actorSkillsClient source mleader+  let allAssocs = eqpAssocs ++ bodyAssocs+  case filter (not . unknownPrecious . snd . snd)+       $ strongestSlotNoFilter Effect.EqpSlotWeapon allAssocs of+    _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> return []+    [] -> return []+    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]++sumOrganEqpClient :: MonadClient m+                  => Effect.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
− Game/LambdaHack/Client/Config.hs 
@@ -1,28 +0,0 @@--- | Personal game configuration file type definitions.-module Game.LambdaHack.Client.Config-  ( ConfigUI(..)-  ) where--import Control.DeepSeq--import Data.Text (Text)-import Game.LambdaHack.Common.HumanCmd-import qualified Game.LambdaHack.Common.Key as K---- | Fully typed contents of the UI config file. This config--- is a part of a game client.-data ConfigUI = ConfigUI-  { -- commands-    configCommands    :: ![(K.KM, (CmdCategory, HumanCmd))]-    -- hero names-  , configHeroNames   :: ![(Int, Text)]-    -- ui-  , configFont        :: !String-  , configHistoryMax  :: !Int-  , configMaxFps      :: !Int-  , configNoAnim      :: !Bool-  , configRunStopMsgs :: !Bool-  }-  deriving Show--instance NFData ConfigUI
− Game/LambdaHack/Client/Draw.hs 
@@ -1,280 +0,0 @@--- | Display game data on the screen using one of the available frontends--- (determined at compile time with cabal flags).-module Game.LambdaHack.Client.Draw-  ( ColorMode(..), draw-  ) where--import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T--import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Actor as Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Animation-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Item as Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ActorKind-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind---- | Color mode for the display.-data ColorMode =-    ColorFull  -- ^ normal, with full colours-  | ColorBW    -- ^ black+white only---- TODO: split up and generally rewrite.--- | Draw the whole screen: level map and status area.--- Pass at most a single page if overlay of text unchanged--- to the frontends to display separately or overlay over map,--- depending on the frontend.-draw :: Bool -> ColorMode -> Kind.COps -> Perception -> LevelId-     -> Maybe ActorId -> Maybe Point -> Maybe Point-     -> Maybe (PointArray.Array BfsDistance, Maybe [Point])-     -> StateClient -> State-     -> Text -> Text -> Overlay-     -> SingleFrame-draw sfBlank dm cops per drawnLevelId mleader cursorPos tgtPos bfsmpathRaw-     cli@StateClient{ stgtMode, seps, sdisco, sexplored-                    , smarkVision, smarkSmell, smarkSuspect, swaitTimes } s-     cursorDesc targetDesc sfTop =-  let Kind.COps{cotile=cotile@Kind.Ops{okind=tokind, ouniqGroup}} = cops-      (lvl@Level{lxsize, lysize, lsmell, ltime}) = sdungeon s EM.! drawnLevelId-      (bl, blLength) = case (cursorPos, mleader) of-        (Just cursor, Just leader) ->-          let Actor{bpos, blid} = getActorBody leader s-          in if blid /= drawnLevelId-             then ([cursor], 0)-             else ( fromMaybe [] $ bla lxsize lysize seps bpos cursor-                  , chessDist bpos cursor )-        _ -> ([], 0)-      mpath = maybe Nothing (\(_, mp) -> if blLength == 0-                                         then Nothing-                                         else mp) bfsmpathRaw-      actorsHere = actorAssocs (const True) drawnLevelId s-      cursorHere = find (\(_, m) -> cursorPos == Just (Actor.bpos m))-                   actorsHere-      shiftedBTrajectory = case cursorHere of-        Just (_, Actor{btrajectory = Just p, bpos = prPos}) -> trajectoryToPath prPos p-        _ -> []-      unknownId = ouniqGroup "unknown space"-      dis pos0 =-        let tile = lvl `at` pos0-            tk = tokind tile-            items = lvl `atI` pos0-            sml = EM.findWithDefault timeZero pos0 lsmell-            smlt = sml `timeAdd` timeNegate ltime-            viewActor aid Actor{bsymbol, bcolor, bhp, bproj}-              | Just aid == mleader = (symbol, inverseVideo)-              | otherwise = (symbol, Color.defAttr {Color.fg = bcolor})-             where-              symbol | bhp <= 0 && not bproj = '%'-                     | otherwise = bsymbol-            rainbow p = Color.defAttr {Color.fg =-                                         toEnum $ fromEnum p `rem` 14 + 1}-            -- smarkSuspect is an optional overlay, so let's overlay it-            -- over both visible and invisible tiles.-            vcolor-              | smarkSuspect && Tile.isSuspect cotile tile = Color.BrCyan-              | vis = tcolor tk-              | otherwise = tcolor2 tk-            viewItem i =-              ( jsymbol i-              , Color.defAttr {Color.fg = flavourToColor $ jflavour i} )-            fgOnPathOrLine = case (vis, Tile.isWalkable cotile tile) of-              _ | tile == unknownId -> Color.BrBlack-              _ | Tile.isSuspect cotile tile -> Color.BrCyan-              (True, True)   -> Color.BrGreen-              (True, False)  -> Color.BrRed-              (False, True)  -> Color.Green-              (False, False) -> Color.Red-            atttrOnPathOrLine = if Just pos0 `elem` [cursorPos, tgtPos]-                                then inverseVideo {Color.fg = fgOnPathOrLine}-                                else Color.defAttr {Color.fg = fgOnPathOrLine}-            (char, attr0) =-              case find (\(_, m) -> pos0 == Actor.bpos m) actorsHere of-                _ | isJust stgtMode-                    && (elem pos0 bl || elem pos0 shiftedBTrajectory) ->-                  ('*', atttrOnPathOrLine)  -- line takes precedence over path-                _ | isJust stgtMode-                    && (maybe False (elem pos0) mpath) ->-                  (';', atttrOnPathOrLine)-                Just (aid, m) -> viewActor aid m-                _ | smarkSmell && smlt > timeZero ->-                  (timeToDigit smellTimeout smlt, rainbow pos0)-                  | otherwise ->-                  case EM.keys items of-                    [] -> (tsymbol tk, Color.defAttr {Color.fg = vcolor})-                    i : _ -> viewItem $ getItemBody i s-            vis = ES.member pos0 $ totalVisible per-            visPl = case (mleader, bfsmpathRaw) of-              (Just leader, Just (bfs, _)) ->-                 let Actor{bpos} = getActorBody leader s-                 in posAimsPos bfs bpos pos0-              _ -> False-            a = case dm of-                  ColorBW   -> Color.defAttr-                  ColorFull ->-                    if smarkVision-                    then if visPl-                         then attr0 {Color.bg = Color.Magenta}-                         else if vis-                              then attr0 {Color.bg = Color.Blue}-                              else attr0-                    else attr0-        in Color.AttrChar a char-      showN2 n = T.justifyRight 2 ' ' (tshow n)-      addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      arenaStatus = drawArenaStatus (ES.member drawnLevelId sexplored) lvl-      cursorText = (if isJust stgtMode then "cursor>" else "Cursor:")-                   <+> cursorDesc-      lineText = let space = 40 - T.length cursorText - 1-                     lText | blLength == 0 = ""-                           | otherwise = "(line" <+> showN2 blLength <> ")"-                 in if T.length lText > space-                    then ""-                    else T.justifyRight space ' ' lText-      cursorStatus = addAttr $ T.justifyLeft 40 ' ' $ cursorText <+> lineText-      selectedStatus = drawSelected cli s drawnLevelId mleader-      leaderStatus = drawLeaderStatus cops s sdisco swaitTimes mleader-      targetText = "Target:" <+> targetDesc-      pathText = let space = 40 - T.length targetText - 1-                     len = case (tgtPos, bfsmpathRaw) of-                       (Just target, Just (bfs, _)) ->-                         fromMaybe 0 (accessBfs bfs target)-                       _ -> 0-                     pText | len == 0 = ""-                           | otherwise = "(path" <+> showN2 len <> ")"-                 in if T.length pText > space-                    then ""-                    else T.justifyRight space ' ' pText-      targetStatus = addAttr $ T.justifyLeft 40 ' ' $ targetText <+> pathText-      sfBottom =-        [ encodeLine $ arenaStatus ++ cursorStatus-        , encodeLine $ selectedStatus ++ leaderStatus ++ targetStatus ]-      fLine y = encodeLine $-        let f l x = let ac = dis $ Point x y in ac : l-        in foldl' f [] [lxsize-1,lxsize-2..0]-      sfLevel =  -- fully evaluated-        let f l y = let !line = fLine y in line : l-        in foldl' f [] [lysize-1,lysize-2..0]-  in SingleFrame{..}--inverseVideo :: Color.Attr-inverseVideo = Color.Attr { Color.fg = Color.bg Color.defAttr-                          , Color.bg = Color.fg Color.defAttr }--drawArenaStatus :: Bool -> Level -> [Color.AttrChar]-drawArenaStatus explored Level{ldepth, ldesc, lseen, lclear} =-  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      seenN = 100 * lseen `div` lclear-      seenTxt | explored || seenN >= 100 = "all"-              | otherwise = T.justifyLeft 3 ' ' (tshow seenN <> "%")-      lvlN = T.justifyLeft 2 ' ' (tshow $ abs ldepth)-      seenStatus = T.justifyLeft 11 ' ' ("[" <> seenTxt <+> "seen]")-  in addAttr $ lvlN <+> T.justifyLeft 25 ' ' ldesc <+> seenStatus--drawLeaderStatus :: Kind.COps -> State -> Discovery-                 -> Int -> Maybe ActorId-                 -> [Color.AttrChar]-drawLeaderStatus cops s sdisco waitTimes mleader =-  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      stats = case mleader of-        Just leader ->-          let Kind.COps{coactor=Kind.Ops{okind}} = cops-              (bitems, bracedL, ahpS, bhpS) =-                let mpl@Actor{bkind, bhp} = getActorBody leader s-                    ActorKind{ahp} = okind bkind-                in (getActorItem leader s, braced mpl,-                    tshow (maxDice ahp), tshow bhp)-              damage = case Item.strongestSword cops bitems of-                Just (_, (_, sw)) ->-                  case Item.jkind sdisco sw of-                    Just _ ->-                      case jeffect sw of-                        Hurt dice p -> tshow dice <> "+" <> tshow p-                        _ -> ""-                    Nothing -> "5d1"  -- TODO: ?-                Nothing -> "5d1"  -- TODO; use the item 'fist'-              -- Indicate the actor is braced (was waiting last move).-              -- It's a useful feedback for the otherwise hard to observe-              -- 'wait' command.-              slashes = ["|", "\\", "|", "/"]-              slashPick | bracedL =-                slashes !! (max 0 (waitTimes - 1) `mod` length slashes)-                        | otherwise = "/"-              bracePick | bracedL   = "}"-                        | otherwise = ":"-              hpText = bhpS <> slashPick <> ahpS-          in T.justifyLeft 12 ' '-               ("Dmg:" <> (if T.length damage < 8 then " " else "") <> damage)-             <+> "HP" <> bracePick <> T.justifyRight 7 ' ' hpText-             <> " "-        Nothing ->-             T.justifyLeft 12 ' ' "Dmg: ---"-             <+> T.justifyRight 10 ' ' "HP:  --/--"-             <> " "-  in addAttr stats--drawSelected :: StateClient -> State -> LevelId -> Maybe ActorId-             -> [Color.AttrChar]-drawSelected cli s drawnLevelId mleader =-  let selected = sselected cli-      viewOurs (aid, Actor{bsymbol, bcolor, bhp})-        | otherwise =-          let cattr = Color.defAttr {Color.fg = bcolor}-              sattr-               | Just aid == mleader = inverseVideo-               | ES.member aid selected =-                   -- TODO: in the future use a red rectangle instead-                   -- of background and mark them on the map, too;-                   -- also, perhaps blink all selected on the map,-                   -- when selection changes-                   if bcolor /= Color.Blue-                   then cattr {Color.bg = Color.Blue}-                   else cattr {Color.bg = Color.Magenta}-               | otherwise = cattr-          in ( (bhp > 0, bsymbol /= '@', bsymbol, bcolor, aid)-             , Color.AttrChar sattr bsymbol )-      ours = actorNotProjAssocs (== sside cli) drawnLevelId s-      maxViewed = 14-      -- Don't show anything if the only actor on the level is the leader.-      -- He's clearly highlighted on the level map, anyway.-      star = let sattr = case ES.size selected of-                   0 -> Color.defAttr {Color.fg = Color.BrBlack}-                   n | n == length ours ->-                     Color.defAttr {Color.bg = Color.Blue}-                   _ -> Color.defAttr-                 char = if length ours > maxViewed then '$' else '*'-             in Color.AttrChar sattr char-      viewed = take maxViewed $ sort $ map viewOurs ours-      addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      allOurs = filter ((== sside cli) . bfid) $ EM.elems $ sactorD s-      nameN n t = T.justifyLeft n ' '-                  $ let firstWord = head $ T.words t-                    in if T.length firstWord > n then "" else firstWord-      fact = sfactionD s EM.! sside cli-      ourName n = addAttr $ nameN n $ playerName $ gplayer fact-      party = if length allOurs <= 1-              then ourName $ maxViewed + 1-              else [star] ++ map snd viewed ++ addAttr " "-                   ++ ourName (maxViewed - 1 - length viewed)-  in party ++ addAttr (T.replicate (maxViewed + 2 - length party) " ")
+ Game/LambdaHack/Client/HandleAtomicClient.hs view
@@ -0,0 +1,390 @@+-- | Handle atomic commands received by the client.+module Game.LambdaHack.Client.HandleAtomicClient+  ( cmdAtomicSemCli, cmdAtomicFilterCli+  ) where++import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Maybe+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.CommonClient+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.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+import Game.LambdaHack.Content.TileKind++-- * RespUpdAtomicAI++-- | Clients keep a subset of atomic commands sent by the server+-- and add some of their own. The result of this function is the list+-- of commands kept for each command received.+cmdAtomicFilterCli :: MonadClient m => UpdAtomic -> m [UpdAtomic]+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+    let t = lvl `at` p+    if t == fromTile+      then return [cmd]+      else do+        -- From @UpdAlterTile@ we know @t == freshClientTile@,+        -- which is uncanny, so we produce a message.+        -- It happens when a client thinks the tile is @t@,+        -- but it's @fromTile@, and @UpdAlterTile@ changes it+        -- to @toTile@. See @updAlterTile@.+        let subject = ""  -- a hack, we we don't handle adverbs well+            verb = "turn into"+            msg = makeSentence [ "the", MU.Text $ tname $ okind t+                               , "at position", MU.Text $ tshow p+                               , "suddenly"  -- adverb+                               , MU.SubjectVerbSg subject verb+                               , MU.AW $ MU.Text $ tname $ okind toTile ]+        return [ cmd  -- reveal the tile+               , UpdMsgAll msg  -- show the message+               ]+  UpdSearchTile aid p fromTile toTile -> do+    b <- getsState $ getActorBody aid+    lvl <- getLevel $ blid b+    let t = lvl `at` p+    return $!+      if t == fromTile+      then -- Fully ignorant. (No intermediate knowledge possible.)+           [ cmd  -- show the message+           , UpdAlterTile (blid b) p fromTile toTile  -- reveal tile+           ]+      else if t == toTile+           then [cmd]  -- Already knows the tile fully, only confirm.+           else -- Misguided.+                assert `failure` "LoseTile fails to reset memory"+                       `twith` (aid, p, fromTile, toTile, b, t, cmd)+  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+  UpdSpotTile lid ts -> do+    Kind.COps{cotile} <- getsState scops+    lvl <- getLevel lid+    -- We ignore the server resending us hidden versions of the tiles+    -- (and resending us the same data we already got).+    -- If the tiles are changed to other variants of the hidden tile,+    -- we can still verify by searching, and the UI warns us "obscured".+    let notKnown (p, t) = let tClient = lvl `at` p+                          in t /= tClient+                             && (not (knownLsecret lvl && isSecretPos lvl p)+                                 || 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+    itemD <- getsState sitemD+    case EM.lookup iid itemD of+      Nothing -> return []+      Just item -> do+        disco <- getsClient sdisco+        if jkindIx item `EM.member` disco+          then do+            discoAE <- getsClient sdiscoAE+            if iid `EM.member` discoAE+              then return []+              else return [UpdDiscoverSeed lid p iid seed]+          else return [cmd]+  UpdCover lid p iid ik _ -> do+    itemD <- getsState sitemD+    case EM.lookup iid itemD of+      Nothing -> return []+      Just item -> do+        disco <- getsClient sdisco+        if jkindIx item `EM.notMember` disco+          then return []+          else do+            discoAE <- getsClient sdiscoAE+            if iid `EM.notMember` discoAE+              then return [cmd]+              else return [UpdCoverKind lid p iid ik]+  UpdDiscoverKind _ _ iid _ -> do+    itemD <- getsState sitemD+    case EM.lookup iid itemD of+      Nothing -> return []+      Just item -> do+        disco <- getsClient sdisco+        if jkindIx item `EM.notMember` disco+        then return []+        else return [cmd]+  UpdCoverKind _ _ iid _ -> do+    itemD <- getsState sitemD+    case EM.lookup iid itemD of+      Nothing -> return []+      Just item -> do+        disco <- getsClient sdisco+        if jkindIx item `EM.notMember` disco+        then return []+        else return [cmd]+  UpdDiscoverSeed _ _ iid _ -> do+    itemD <- getsState sitemD+    case EM.lookup iid itemD of+      Nothing -> return []+      Just item -> do+        disco <- getsClient sdisco+        if jkindIx item `EM.notMember` disco+        then return []+        else do+          discoAE <- getsClient sdiscoAE+          if iid `EM.member` discoAE+            then return []+            else return [cmd]+  UpdCoverSeed _ _ iid _ -> do+    itemD <- getsState sitemD+    case EM.lookup iid itemD of+      Nothing -> return []+      Just item -> do+        disco <- getsClient sdisco+        if jkindIx item `EM.notMember` disco+        then return []+        else do+          discoAE <- getsClient sdiscoAE+          if iid `EM.notMember` discoAE+            then return []+            else return [cmd]+  UpdPerception lid outPer inPer -> do+    -- Here we cheat by setting a new perception outright instead of+    -- in @cmdAtomicSemCli@, to avoid computing perception twice.+    -- TODO: try to assert similar things as for @atomicRemember@:+    -- that posUpdAtomic of all the Lose* commands was visible in old Per,+    -- but is not visible any more.+    perOld <- getPerFid lid+    perception lid outPer inPer+    perNew <- getPerFid lid+    s <- getState+    fid <- getsClient sside+    -- Wipe out actors that just became invisible due to changed FOV.+    -- TODO: perhaps instead create LoseActor for all actors in lprio,+    -- and keep only those where seenAtomicCli is True; this is even+    -- cheaper than repeated posToActor (until it's optimized).+    let outFov = totalVisible perOld ES.\\ totalVisible perNew+        outPrio = concatMap (\p -> posToActors p lid s) $ ES.elems outFov+        fActor ((aid, b), ais) =+          -- TODO: instead of bproj, check that actor sees himself.+          if not (bproj b) && bfid b == fid+          then Nothing  -- optimization: the actor is soon lost anyway,+                        -- e.g., via domination, so don't bother+          else Just $ UpdLoseActor aid b ais+        outActor = mapMaybe fActor outPrio+    -- Wipe out remembered items on tiles that now came into view.+    Level{lfloor, lsmell} <- getLevel lid+    let inFov = totalVisible perNew ES.\\ totalVisible perOld+        pMaybe p = maybe Nothing (\x -> Just (p, x))+        inFloor = mapMaybe (\p -> pMaybe p $ EM.lookup p lfloor)+                           (ES.elems inFov)+        fItem p (iid, k) = UpdLoseItem iid (getItemBody iid s) k (CFloor lid p)+        fBag (p, bag) = map (fItem p) $ EM.assocs bag+        inItem = concatMap fBag inFloor+    -- Remembered map tiles not wiped out, due to optimization in @updSpotTile@.+    -- Wipe out remembered smell on tiles that now came into smell Fov.+    let inSmellFov = smellVisible perNew ES.\\ smellVisible perOld+        inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p lsmell)+                        (ES.elems inSmellFov)+        inSmell = if null inSm then [] else [UpdLoseSmell lid inSm]+    let seenNew = seenAtomicCli False fid perNew+        seenOld = seenAtomicCli False fid perOld+    -- TODO: these assertions are probably expensive+    psActor <- mapM posUpdAtomic outActor+    -- Verify that we forget only previously seen actors.+    assert (allB seenOld psActor) skip+    -- Verify that we forget only currently invisible actors.+    assert (allB (not . seenNew) psActor) skip+    psItemSmell <- mapM posUpdAtomic $ inItem ++ inSmell+    -- Verify that we forget only previously invisible items and smell.+    assert (allB (not . seenOld) psItemSmell) skip+    -- Verify that we forget only currently seen items and smell.+    assert (allB seenNew psItemSmell) skip+    return $! cmd : outActor ++ inItem ++ inSmell+  _ -> return [cmd]++deleteSmell :: MonadClient m => ActorId -> Point -> m [UpdAtomic]+deleteSmell aid pos = do+  b <- getsState $ getActorBody aid+  smellRadius <- sumOrganEqpClient Effect.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 ()+cmdAtomicSemCli cmd = case cmd of+  UpdCreateActor aid body _ -> createActor aid body+  UpdDestroyActor aid b _ -> destroyActor aid b True+  UpdSpotActor aid body _ -> createActor aid body+  UpdLoseActor aid b _ -> destroyActor aid b False+  UpdLeadFaction fid source target -> do+    side <- getsClient sside+    when (side == fid) $ do+      mleader <- getsClient _sleader+      assert (mleader == source     -- somebody changed the leader for us+              || mleader == target  -- we changed the leader originally+              `blame` "unexpected leader" `twith` (cmd, mleader)) skip+      modifyClient $ \cli -> cli {_sleader = target}+  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+  UpdPerception lid outPer inPer -> perception lid outPer inPer+  UpdRestart side sdisco sfper _ sdebugCli sgameMode -> do+    shistory <- getsClient shistory+    sreport <- getsClient sreport+    isAI <- getsClient sisAI+    let cli = defStateClient shistory sreport side isAI+    putClient cli { sdisco+                  , sfper+                  -- , sundo = [UpdAtomic cmd]+                  , scurDifficulty = sdifficultyCli sdebugCli+                  , sgameMode+                  , sdebugCli }+  UpdResume _fid sfper -> modifyClient $ \cli -> cli {sfper}+  UpdKillExit _fid -> killExit+  UpdSaveBkp -> saveClient+  _ -> return ()++createActor :: MonadClient m => ActorId -> Actor -> m ()+createActor aid _b = do+  let affect tgt = case tgt of+        TEnemyPos a _ _ permit | a == aid -> TEnemy a permit+        _ -> tgt+      affect3 (tgt, mpath) = case tgt of+        TEnemyPos a _ _ permit | a == aid -> (TEnemy a permit, Nothing)+        _ -> (tgt, mpath)+  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}+  modifyClient $ \cli -> cli {scursor = affect $ scursor cli}++destroyActor :: MonadClient m => ActorId -> Actor -> Bool -> m ()+destroyActor aid b destroy = do+  when destroy $ modifyClient $ updateTarget aid (const Nothing)  -- gc+  modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli}  -- gc+  let affect tgt = case tgt of+        TEnemy a permit | a == aid -> TEnemyPos a (blid b) (bpos b) permit+          -- Don't consider @destroy@, because even if actor dead, it makes+          -- sense to go to last known location to loot or find others.+        _ -> tgt+      affect3 (tgt, mpath) =+        let newMPath = case mpath of+              Just (_, (goal, _)) | goal /= bpos b -> Nothing+              _ -> mpath  -- foe slow enough, so old path good+        in (affect tgt, newMPath)+  modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}+  modifyClient $ \cli -> cli {scursor = affect $ scursor cli}++perception :: MonadClient m => LevelId -> Perception -> Perception -> m ()+perception lid outPer inPer = do+  -- Clients can't compute FOV on their own, because they don't know+  -- if unknown tiles are clear or not. Server would need to send+  -- info about properties of unknown tiles, which complicates+  -- and makes heavier the most bulky data set in the game: tile maps.+  -- Note we assume, but do not check that @outPer@ is contained+  -- in current perception and @inPer@ has no common part with it.+  -- It would make the already very costly operation even more expensive.+  perOld <- getPerFid lid+  -- Check if new perception is already set in @cmdAtomicFilterCli@+  -- or if we are doing undo/redo, which does not involve filtering.+  -- The data structure is strict, so the cheap check can't be any simpler.+  let interAlready per =+        Just $ totalVisible per `ES.intersection` totalVisible perOld+      unset = maybe False ES.null (interAlready inPer)+              || maybe False (not . ES.null) (interAlready outPer)+  when unset $ do+    let adj Nothing = assert `failure` "no perception to alter" `twith` lid+        adj (Just per) = Just $ addPer (diffPer per outPer) inPer+        f = EM.alter adj lid+    modifyClient $ \cli -> cli {sfper = f (sfper cli)}++discoverKind :: MonadClient m+             => LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m ()+discoverKind lid p iid ik = do+  item <- getsState $ getItemBody iid+  let f Nothing = Just ik+      f Just{} = assert `failure` "already discovered"+                        `twith` (lid, p, iid, ik)+  modifyClient $ \cli -> cli {sdisco = EM.alter f (jkindIx item) (sdisco cli)}++coverKind :: MonadClient m+          => LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m ()+coverKind lid p iid ik = do+  item <- getsState $ getItemBody iid+  let f Nothing = assert `failure` "already covered" `twith` (lid, p, iid, ik)+      f (Just ik2) = assert (ik == ik2 `blame` "unexpected covered item kind"+                                       `twith` (ik, ik2)) Nothing+  modifyClient $ \cli -> cli {sdisco = EM.alter f (jkindIx item) (sdisco cli)}++discoverSeed :: MonadClient m+             => LevelId -> Point -> ItemId -> ItemSeed -> m ()+discoverSeed lid p iid seed = do+  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops+  disco <- getsClient sdisco+  item <- getsState $ getItemBody iid+  Level{ldepth} <- getLevel (jlid item)+  totalDepth <- getsState stotalDepth+  case EM.lookup (jkindIx item) disco of+    Nothing -> assert `failure` "kind not known"+                      `twith` (lid, p, 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)+      modifyClient $ \cli -> cli {sdiscoAE = EM.alter f iid (sdiscoAE 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)+      f Just{} = Nothing  -- checking that old and new agree is too much work+  modifyClient $ \cli -> cli {sdiscoAE = EM.alter f iid (sdiscoAE cli)}++killExit :: MonadClient m => m ()+killExit = modifyClient $ \cli -> cli {squit = True}
+ Game/LambdaHack/Client/HandleResponseClient.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleContexts #-}+-- | Semantics of client commands.+module Game.LambdaHack.Client.HandleResponseClient+  ( handleResponseAI, handleResponseUI+  ) where++import Control.Exception.Assert.Sugar++import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.AI+import Game.LambdaHack.Client.HandleAtomicClient+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.ProtocolClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.Response++storeUndo :: MonadClient m => CmdAtomic -> m ()+storeUndo _atomic =+  maybe skip (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli})+    $ Nothing   -- TODO: undoCmdAtomic atomic++handleResponseAI :: (MonadAtomic m, MonadClientWriteRequest RequestAI m)+                 => ResponseAI -> m ()+handleResponseAI cmd = case cmd of+  RespUpdAtomicAI cmdA -> do+    cmds <- cmdAtomicFilterCli cmdA+    mapM_ (\c -> cmdAtomicSemCli c+                 >> execUpdAtomic c) cmds+    mapM_ (storeUndo . UpdAtomic) cmds+  RespQueryAI aid -> do+    cmdC <- queryAI aid+    sendRequest cmdC+  RespPingAI -> do+    pong <- pongAI+    sendRequest pong++handleResponseUI :: ( MonadClientUI m+                    , MonadAtomic m+                    , MonadClientWriteRequest RequestUI m )+                 => ResponseUI -> m ()+handleResponseUI cmd = case cmd of+  RespUpdAtomicUI cmdA -> do+    cmds <- cmdAtomicFilterCli cmdA+    let handle c = do+          oldState <- getState+          oldStateClient <- getClient+          cmdAtomicSemCli c+          execUpdAtomic c+          displayRespUpdAtomicUI False oldState oldStateClient c+    mapM_ handle cmds+    mapM_ (storeUndo . UpdAtomic) cmds  -- TODO: only store cmdA?+  RespSfxAtomicUI sfx -> do+    displayRespSfxAtomicUI False sfx+    storeUndo $ SfxAtomic sfx+  RespQueryUI -> do+    cmdH <- queryUI+    sendRequest cmdH+  RespPingUI -> do+    pong <- pongUI+    sendRequest pong
− Game/LambdaHack/Client/HumanGlobal.hs 
@@ -1,653 +0,0 @@--- | Semantics of 'Command.Cmd' client commands that return server commands.--- A couple of them do not take time, the rest does.--- TODO: document-module Game.LambdaHack.Client.HumanGlobal-  ( -- * Commands that usually take time-    moveRunHuman, waitHuman, pickupHuman, dropHuman-  , projectHuman, applyHuman, alterDirHuman, triggerTileHuman-  , stepToTargetHuman, resendHuman-    -- * Commands that never take time-  , gameRestartHuman, gameExitHuman, gameSaveHuman-    -- * Helper definitions-  , SlideOrCmd, failWith-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Function-import Data.List-import Data.Maybe-import Data.Monoid-import Data.Text (Text)-import qualified Data.Text as T-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.Action-import Game.LambdaHack.Client.Config-import Game.LambdaHack.Client.Draw-import Game.LambdaHack.Client.HumanLocal-import Game.LambdaHack.Client.RunAction-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Animation-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.HumanCmd (Trigger (..))-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Key as K-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.ServerCmd-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ActorKind-import Game.LambdaHack.Content.TileKind as TileKind--type SlideOrCmd a = Either Slideshow a--failWith :: MonadClientUI m => Msg -> m (SlideOrCmd a)-failWith msg = do-  modifyClient $ \cli -> cli {slastKey = Nothing}-  stopPlayBack-  assert (not $ T.null msg) $ fmap Left $ promptToSlideshow msg--failSlides :: MonadClientUI m => Slideshow -> m (SlideOrCmd a)-failSlides slides = do-  modifyClient $ \cli -> cli {slastKey = Nothing}-  stopPlayBack-  return $ Left slides--failSer :: MonadClientUI m => FailureSer -> m (SlideOrCmd a)-failSer = failWith . showFailureSer---- * Move and Run--moveRunHuman :: MonadClientUI m-             => Bool -> Vector -> m (SlideOrCmd CmdTakeTimeSer)-moveRunHuman run dir = do-  tgtMode <- getsClient stgtMode-  if isJust tgtMode then-    fmap Left $ moveCursorHuman dir (if run then 10 else 1)-  else do-    arena <- getArenaUI-    leader <- getLeaderUI-    sb <- getsState $ getActorBody leader-    fact <- getsState $ (EM.! bfid sb) . sfactionD-    let tpos = bpos sb `shift` dir-    -- We start by checking actors at the the target position,-    -- which gives a partial information (actors can be invisible),-    -- as opposed to accessibility (and items) which are always accurate-    -- (tiles can't be invisible).-    tgts <- getsState $ posToActors tpos arena-    case tgts of-      [] -> do  -- move or search or alter-        -- Start running in the given direction. The first turn of running-        -- succeeds much more often than subsequent turns, because we ignore-        -- most of the disturbances, since the player is mostly aware of them-        -- and still explicitly requests a run, knowing how it behaves.-        runStopOrCmd <- moveRunAid leader dir-        case runStopOrCmd of-          Left stopMsg -> failWith stopMsg-          Right runCmd -> do-            sel <- getsClient sselected-            let runMembers = if isSpawnFact fact-                             then [leader]  -- TODO: warn?-                             else ES.toList (ES.delete leader sel) ++ [leader]-                runParams = RunParams { runLeader = leader-                                      , runMembers-                                      , runDist = 0-                                      , runStopMsg = Nothing-                                      , runInitDir = Just dir }-            when run $ modifyClient $ \cli -> cli {srunning = Just runParams}-            return $ Right runCmd-        -- When running, the invisible actor is hit (not displaced!),-        -- so that running in the presence of roving invisible-        -- actors is equivalent to moving (with visible actors-        -- this is not a problem, since runnning stops early enough).-        -- TODO: stop running at invisible actor-      [((target, _), _)] | run ->-        -- Displacing requires accessibility, but it's checked later on.-        displaceAid leader target-      _ : _ : _ | run -> do-        assert (all (bproj . snd . fst) tgts) skip-        failSer DisplaceProjectiles-      ((target, tb), _) : _ -> do-        -- No problem if there are many projectiles at the spot. We just-        -- attack the first one.-        -- We always see actors from our own faction.-        if bfid tb == bfid sb && not (bproj tb) then do-          if isSpawnFact fact then-            failWith "spawners cannot manually change leaders"-          else do-            -- Select adjacent actor by bumping into him. Takes no time.-            success <- pickLeader target-            assert (success `blame` "bump self"-                            `twith` (leader, target, tb)) skip-            return $ Left mempty-        else-          -- Attacking does not require full access, adjacency is enough.-          meleeAid leader target---- | Actor atttacks an enemy actor or his own projectile.-meleeAid :: MonadClientUI m-         => ActorId -> ActorId -> m (SlideOrCmd CmdTakeTimeSer)-meleeAid source target = do-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  sfact <- getsState $ (EM.! bfid sb) . sfactionD-  let returnCmd = return $ Right $ MeleeSer source target-  if not (bproj tb || isAtWar sfact (bfid tb)) then do-    go1 <- displayYesNo ColorBW-             "This attack will start a war. Are you sure?"-    if not go1 then failWith "Attack canceled."-    else if not (bproj tb || not (isAllied sfact (bfid tb))) then do-      go2 <- displayYesNo ColorBW-               "You are bound by an alliance. Really attack?"-      if not go2 then failWith "Attack canceled."-      else returnCmd-    else returnCmd-  else returnCmd-  -- Seeing the actor prevents altering a tile under it, but that-  -- does not limit the player, he just doesn't waste a turn-  -- on a failed altering.---- | Actor swaps position with another.-displaceAid :: MonadClientUI m-            => ActorId -> ActorId -> m (SlideOrCmd CmdTakeTimeSer)-displaceAid source target = do-  cops <- getsState scops-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  let adj = checkAdjacent sb tb-  if not adj then failSer DisplaceDistant-  else do-    let lid = blid sb-    lvl <- getLevel lid-    let spos = bpos sb-        tpos = bpos tb-    -- Displacing requires full access.-    if accessible cops lvl spos tpos then do-      tgts <- getsState $ posToActors tpos lid-      case tgts of-        [] -> assert `failure` (source, sb, target, tb)-        [_] -> do-          return $ Right $ DisplaceSer source target-        _ -> failSer DisplaceProjectiles-    else failSer DisplaceAccess---- * Wait---- | Leader waits a turn (and blocks, etc.).-waitHuman :: MonadClientUI m => m CmdTakeTimeSer-waitHuman = do-  modifyClient $ \cli -> cli {swaitTimes = abs (swaitTimes cli) + 1}-  leader <- getLeaderUI-  return $! WaitSer leader---- * Pickup--pickupHuman :: MonadClientUI m => m (SlideOrCmd CmdTakeTimeSer)-pickupHuman = do-  leader <- getLeaderUI-  body <- getsState $ getActorBody leader-  lvl <- getLevel $ blid body-  -- Check if something is here to pick up. Items are never invisible.-  case EM.minViewWithKey $ lvl `atI` bpos body of-    Nothing -> failWith "nothing here"-    Just ((iid, k), _) ->  do  -- pick up first item; TODO: let pl select item-      item <- getsState $ getItemBody iid-      let l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing-      case assignLetter iid l body of-        Just _ -> return $ Right $ PickupSer leader iid k-        Nothing -> failSer PickupOverfull---- * Drop---- TODO: you can drop an item already on the floor (the '-' is there),--- which is weird and useless.--- | Drop a single item.-dropHuman :: MonadClientUI m => m (SlideOrCmd CmdTakeTimeSer)-dropHuman = do-  -- TODO: allow dropping a given number of identical items.-  Kind.COps{coitem} <- getsState scops-  leader <- getLeaderUI-  bag <- getsState $ getActorBag leader-  inv <- getsState $ getActorInv leader-  ggi <- getAnyItem leader "What to drop?" bag inv "in inventory"-  case ggi of-    Right ((iid, item), (_, container)) ->-      case container of-        CFloor{} -> failWith "never mind"-        CActor aid _ -> do-          assert (aid == leader) skip-          disco <- getsClient sdisco-          subject <- partAidLeader leader-          msgAdd $ makeSentence-            [ MU.SubjectVerbSg subject "drop"-            , partItemWs coitem disco 1 item ]-          return $ Right $ DropSer leader iid 1-    Left slides -> return $ Left slides--allObjectsName :: Text-allObjectsName = "Objects"---- | Let the human player choose any item from a list of items.-getAnyItem :: MonadClientUI m-           => ActorId-           -> Text     -- ^ prompt-           -> ItemBag  -- ^ all items in question-           -> ItemInv  -- ^ inventory characters-           -> Text     -- ^ how to refer to the collection of items-           -> m (SlideOrCmd ((ItemId, Item), (Int, Container)))-getAnyItem leader prompt = getItem leader prompt (const True) allObjectsName--data ItemDialogState = INone | ISuitable | IAll deriving Eq---- | Let the human player choose a single, preferably suitable,--- item from a list of items.-getItem :: MonadClientUI m-        => ActorId-        -> Text            -- ^ prompt message-        -> (Item -> Bool)  -- ^ which items to consider suitable-        -> Text            -- ^ how to describe suitable items-        -> ItemBag         -- ^ all items in question-        -> ItemInv         -- ^ inventory characters-        -> Text            -- ^ how to refer to the collection of items-        -> m (SlideOrCmd ((ItemId, Item), (Int, Container)))-getItem aid prompt p ptext bag invRaw isn = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  lvl <- getLevel $ blid b-  s <- getState-  body <- getsState $ getActorBody aid-  let inv = EM.filter (`EM.member` bag) invRaw-      checkItem (l, iid) = ((iid, getItemBody iid s), (bag EM.! iid, l))-      is0 = map checkItem $ EM.assocs inv-      pos = bpos body-      tis = lvl `atI` pos-      floorFull = not $ EM.null tis-      (floorMsg, floorKey) | floorFull = (", -", [K.Char '-'])-                           | otherwise = ("", [])-      isp = filter (p . snd . fst) is0-      bestFull = not $ null isp-      (bestMsg, bestKey)-        | bestFull =-          let bestLetter = invChar $ maximum $ map (snd . snd) isp-          in (", RET(" <> T.singleton bestLetter <> ")", [K.Return])-        | otherwise = ("", [])-      keys ims =-        let mls = map (snd . snd) ims-            ks = bestKey ++ floorKey ++ [K.Char '?']-                 ++ map (K.Char . invChar) mls-        in zipWith K.KM (repeat K.NoModifier) ks-      choice ims =-        if null ims-        then "[?" <> floorMsg-        else let mls = map (snd . snd) ims-                 r = letterRange mls-             in "[" <> r <> ", ?" <> floorMsg <> bestMsg-      ask = do-        if null is0 && EM.null tis-        then failWith "Not carrying anything."-        else perform INone-      invP = EM.filter (\iid -> p (getItemBody iid s)) inv-      perform itemDialogState = do-        let (ims, invOver, msg) = case itemDialogState of-              INone     -> (isp, EM.empty, prompt)-              ISuitable -> (isp, invP, ptext <+> isn <> ".")-              IAll      -> (is0, inv, allObjectsName <+> isn <> ".")-        io <- itemOverlay bag invOver-        akm <- displayChoiceUI (msg <+> choice ims) io (keys is0)-        case akm of-          Left slides -> failSlides slides-          Right (km@K.KM {..}) -> do-            assert (modifier == K.NoModifier) skip-            case key of-              K.Char '?' -> case itemDialogState of-                INone -> if EM.null invP-                         then perform IAll-                         else perform ISuitable-                ISuitable | ptext /= allObjectsName -> perform IAll-                _ -> perform INone-              K.Char '-' | floorFull ->-                -- TODO: let player select item-                return $ Right-                       $ maximumBy (compare `on` fst . fst)-                       $ map (\(iid, k) ->-                               ((iid, getItemBody iid s),-                                (k, CFloor (blid b) pos)))-                       $ EM.assocs tis-              K.Char l ->-                case find ((InvChar l ==) . snd . snd) is0 of-                  Nothing -> assert `failure` "unexpected inventory letter"-                                    `twith` (km, l,  is0)-                  Just (iidItem, (k, l2)) ->-                    return $ Right (iidItem, (k, CActor aid l2))-              K.Return | bestFull ->-                let (iidItem, (k, l2)) = maximumBy (compare `on` snd . snd) isp-                in return $ Right (iidItem, (k, CActor aid l2))-              _ -> assert `failure` "unexpected key:" `twith` km-  ask---- * Project--projectHuman :: MonadClientUI m-             => [Trigger] -> m (SlideOrCmd CmdTakeTimeSer)-projectHuman ts = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  tgtPos <- leaderTgtToPos-  case tgtPos of-    Nothing -> failWith "last target invalid"-    Just pos | pos == bpos b -> failWith "cannot aim at oneself"-    Just pos -> do-      canAim <- leaderTgtAims-      case canAim of-        Nothing -> projectAid leader ts pos-        Just cause -> failWith cause--projectAid :: MonadClientUI m-           => ActorId -> [Trigger] -> Point -> m (SlideOrCmd CmdTakeTimeSer)-projectAid source ts tpos = do-  Kind.COps{coactor=Kind.Ops{okind}, cotile} <- getsState scops-  eps <- getsClient seps-  sb <- getsState $ getActorBody source-  let lid = blid sb-      spos = bpos sb-  fact <- getsState $ (EM.! bfid sb) . sfactionD-  Level{lxsize, lysize} <- getLevel lid-  foes <- getsState $ actorNotProjList (isAtWar fact) lid-  if foesAdjacent lxsize lysize spos foes-    then failSer ProjectBlockFoes-    else do-      case bla lxsize lysize eps spos tpos of-        Nothing -> failSer ProjectAimOnself-        Just [] -> assert `failure` "project from the edge of level"-                          `twith` (spos, tpos, sb, ts)-        Just (pos : _) -> do-          lvl <- getLevel lid-          let t = lvl `at` pos-          if not $ Tile.isWalkable cotile t-            then failSer ProjectBlockTerrain-            else do-              mab <- getsState $ posToActor pos lid-              if maybe True (bproj . snd . fst) mab-              then if not (asight $ okind $ bkind sb)-                   then failSer ProjectBlind-                   else projectBla source tpos eps ts-              else failSer ProjectBlockActor--projectBla :: MonadClientUI m-           => ActorId -> Point -> Int -> [Trigger]-           -> m (SlideOrCmd CmdTakeTimeSer)-projectBla source tpos eps ts = do-  let (verb1, object1) = case ts of-        [] -> ("aim", "object")-        tr : _ -> (verb tr, object tr)-      triggerSyms = triggerSymbols ts-  bag <- getsState $ getActorBag source-  inv <- getsState $ getActorInv source-  ggi <- getGroupItem source bag inv object1 triggerSyms-           (makePhrase ["What to", verb1 MU.:> "?"]) "in inventory"-  case ggi of-    Right ((iid, _), (_, container)) ->-      return $ Right $ ProjectSer source tpos eps iid container-    Left slides -> return $ Left slides--triggerSymbols :: [Trigger] -> [Char]-triggerSymbols [] = []-triggerSymbols (ApplyItem{symbol} : ts) = symbol : triggerSymbols ts-triggerSymbols (_ : ts) = triggerSymbols ts---- * Apply--applyHuman :: MonadClientUI m => [Trigger] -> m (SlideOrCmd CmdTakeTimeSer)-applyHuman ts = do-  leader <- getLeaderUI-  bag <- getsState $ getActorBag leader-  inv <- getsState $ getActorInv leader-  let (verb1, object1) = case ts of-        [] -> ("activate", "object")-        tr : _ -> (verb tr, object tr)-      triggerSyms = triggerSymbols ts-  ggi <- getGroupItem leader bag inv object1 triggerSyms-           (makePhrase ["What to", verb1 MU.:> "?"]) "in inventory"-  case ggi of-    Right ((iid, _), (_, container)) ->-      return $ Right $ ApplySer leader iid container-    Left slides -> return $ Left slides---- | Let a human player choose any item with a given group name.--- Note that this does not guarantee the chosen item belongs to the group,--- as the player can override the choice.-getGroupItem :: MonadClientUI m-             => ActorId-             -> ItemBag  -- ^ all objects in question-             -> ItemInv  -- ^ inventory characters-             -> MU.Part  -- ^ name of the group-             -> [Char]   -- ^ accepted item symbols-             -> Text     -- ^ prompt-             -> Text     -- ^ how to refer to the collection of objects-             -> m (SlideOrCmd ((ItemId, Item), (Int, Container)))-getGroupItem leader is inv object syms prompt packName = do-  let choice i = jsymbol i `elem` syms-      header = makePhrase [MU.Capitalize (MU.Ws object)]-  getItem leader prompt choice header is inv packName---- * AlterDir---- | Ask for a direction and alter a tile, if possible.-alterDirHuman :: MonadClientUI m => [Trigger] -> m (SlideOrCmd CmdTakeTimeSer)-alterDirHuman ts = do-  let verb1 = case ts of-        [] -> "alter"-        tr : _ -> verb tr-      keys = zipWith K.KM (repeat K.NoModifier) K.dirAllMoveKey-      prompt = makePhrase ["What to", verb1 MU.:> "? [movement key"]-  me <- displayChoiceUI prompt emptyOverlay keys-  case me of-    Left slides -> failSlides slides-    Right e -> do-      leader <- getLeaderUI-      K.handleDir e (flip (alterTile leader) ts) (failWith "never mind")---- | Player tries to alter a tile using a feature.-alterTile :: MonadClientUI m-          => ActorId -> Vector -> [Trigger]-          -> m (SlideOrCmd CmdTakeTimeSer)-alterTile source dir ts = do-  Kind.COps{cotile} <- getsState scops-  b <- getsState $ getActorBody source-  lvl <- getLevel $ 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 cotile alterFeats t-    feat : _ -> return $ Right $ AlterSer source tpos $ Just feat--alterFeatures :: [Trigger] -> [F.Feature]-alterFeatures [] = []-alterFeatures (AlterFeature{feature} : ts) = feature : alterFeatures ts-alterFeatures (_ : ts) = alterFeatures ts---- | Guess and report why the bump command failed.-guessAlter :: Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> Msg-guessAlter cotile (F.OpenTo _ : _) t-  | Tile.isClosable cotile t = "already open"-guessAlter _ (F.OpenTo _ : _) _ = "cannot be opened"-guessAlter cotile (F.CloseTo _ : _) t-  | Tile.isOpenable cotile t = "already closed"-guessAlter _ (F.CloseTo _ : _) _ = "cannot be closed"-guessAlter _ _ _ = "never mind"---- * TriggerTile---- | Leader tries to trigger the tile he's standing on.-triggerTileHuman :: MonadClientUI m-                 => [Trigger] -> m (SlideOrCmd CmdTakeTimeSer)-triggerTileHuman ts = do-  tgtMode <- getsClient stgtMode-  if isJust tgtMode then do-    let getK tfs = case tfs of-          TriggerFeature {feature = F.Cause (Effect.Ascend k)} : _ -> Just k-          _ : rest -> getK rest-          [] -> Nothing-        mk = getK ts-    case mk of-      Nothing -> failWith  "never mind"-      Just k -> fmap Left $ tgtAscendHuman k-  else do-    leader <- getLeaderUI-    triggerTile leader ts---- | Player tries to trigger a tile using a feature.-triggerTile :: MonadClientUI m-            => ActorId -> [Trigger]-            -> m (SlideOrCmd CmdTakeTimeSer)-triggerTile leader ts = do-  Kind.COps{cotile} <- getsState scops-  b <- getsState $ getActorBody leader-  lvl <- getLevel $ blid b-  let t = lvl `at` bpos b-      triggerFeats = triggerFeatures ts-  case filter (\feat -> Tile.hasFeature cotile feat t) triggerFeats of-    [] -> failWith $ guessTrigger cotile triggerFeats t-    feat : _ -> do-      go <- verifyTrigger leader feat-      case go of-        Right () -> return $ Right $ TriggerSer leader $ Just feat-        Left slides -> return $ Left slides--triggerFeatures :: [Trigger] -> [F.Feature]-triggerFeatures [] = []-triggerFeatures (TriggerFeature{feature} : ts) = feature : triggerFeatures ts-triggerFeatures (_ : ts) = triggerFeatures ts---- | Verify important feature triggers, such as fleeing the dungeon.-verifyTrigger :: MonadClientUI m-              => ActorId -> F.Feature -> m (SlideOrCmd ())-verifyTrigger leader feat = case feat of-  F.Cause Effect.Escape{} -> do-    cops <- getsState scops-    b <- getsState $ getActorBody leader-    side <- getsClient sside-    fact <- getsState $ (EM.! side) . sfactionD-    let isHero = isHeroFact cops fact-    if not isHero then failWith-      "This is the way out, but where would you go in this alien world?"-    else do-      go <- displayYesNo ColorFull "This is the way out. Really leave now?"-      if not go then failWith "Game resumed."-      else do-        (_, total) <- getsState $ calculateTotal b-        if total == 0 then do-          -- The player can back off at each of these steps.-          go1 <- displayMore ColorBW-                   "Afraid of the challenge? Leaving so soon and empty-handed?"-          if not go1 then failWith "Brave soul!"-          else do-             go2 <- displayMore ColorBW-                     "Next time try to grab some loot before escape!"-             if not go2 then failWith "Here's your chance!"-             else return $ Right ()-        else return $ Right ()-  _ -> return $ Right ()---- | Guess and report why the bump command failed.-guessTrigger :: Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> Msg-guessTrigger cotile fs@(F.Cause (Effect.Ascend k) : _) t-  | Tile.hasFeature cotile (F.Cause (Effect.Ascend (-k))) t =-    if k > 0 then "the way goes down, not up"-    else if k < 0 then "the way goes up, not down"-    else assert `failure` fs-guessTrigger _ fs@(F.Cause (Effect.Ascend k) : _) _ =-    if k > 0 then "cannot ascend"-    else if k < 0 then "cannot descend"-    else assert `failure` fs-guessTrigger _ _ _ = "never mind"---- * StepToTarget--stepToTargetHuman :: MonadClientUI m => m (SlideOrCmd CmdTakeTimeSer)-stepToTargetHuman = do-  tgtMode <- getsClient stgtMode-  -- Movement is legal only outside targeting mode.-  -- TODO: use this command for something in targeting mode.-  if isJust tgtMode then failWith "cannot move in targeting mode"-  else do-    leader <- getLeaderUI-    b <- getsState $ getActorBody leader-    tgtPos <- leaderTgtToPos-    case tgtPos of-      Nothing -> failWith "target not set"-      Just c | c == bpos b -> failWith "target reached"-      Just c -> do-        (_, mpath) <- getCacheBfsAndPath leader c-        case mpath of-          Nothing -> failWith "no route to target"-          Just [] -> assert `failure` (leader, b, bpos b, c)-          Just (p1 : _) -> do-            as <- getsState $ posToActors p1 (blid b)-            if not $ null as then-              failWith "actor in the path to target"-            else-              moveRunHuman False $ towards (bpos b) p1---- * Resend--resendHuman :: MonadClientUI m => m (SlideOrCmd CmdTakeTimeSer)-resendHuman = do-  slastCmd <- getsClient slastCmd-  case slastCmd of-    Just cmd -> return $ Right cmd-    Nothing -> failWith "no time-taking command to repeat"---- * GameRestart; does not take time--gameRestartHuman :: MonadClientUI m => Text -> m (SlideOrCmd CmdSer)-gameRestartHuman t = do-  let msg = "You just requested a new" <+> t <+> "game."-  b1 <- displayMore ColorFull msg-  if not b1 then failWith "never mind"-  else do-    b2 <- displayYesNo ColorBW-            "Current progress will be lost! Really restart the game?"-    msg2 <- rndToAction $ oneOf-              [ "Yea, would be a pity to leave them all to die."-              , "Yea, a shame to get your own team stranded." ]-    if not b2 then failWith msg2-    else do-      leader <- getLeaderUI-      DebugModeCli{sdifficultyCli} <- getsClient sdebugCli-      ConfigUI{configHeroNames} <- getsClient sconfigUI-      return $ Right $ GameRestartSer leader t sdifficultyCli configHeroNames---- * GameExit; does not take time--gameExitHuman :: MonadClientUI m => m (SlideOrCmd CmdSer)-gameExitHuman = do-  go <- displayYesNo ColorFull "Really save and exit?"-  if go then do-    leader <- getLeaderUI-    DebugModeCli{sdifficultyCli} <- getsClient sdebugCli-    return $ Right $ GameExitSer leader sdifficultyCli-  else failWith "Save and exit canceled."---- * GameSave; does not take time--gameSaveHuman :: MonadClientUI m => m CmdSer-gameSaveHuman = do-  leader <- getLeaderUI-  -- TODO: do not save to history:-  msgAdd "Saving game backup."-  return $! GameSaveSer leader
− Game/LambdaHack/Client/HumanLocal.hs 
@@ -1,758 +0,0 @@--- | Semantics of 'HumanCmd' client commands that do not return--- server commands. None of such commands takes game time.--- TODO: document-module Game.LambdaHack.Client.HumanLocal-  ( -- * Assorted commands that do not notify the server-    gameDifficultyCycle-  , pickLeaderHuman, memberCycleHuman, memberBackHuman, inventoryHuman-  , selectActorHuman, selectNoneHuman, clearHuman, repeatHuman, recordHuman-  , historyHuman, markVisionHuman, markSmellHuman, markSuspectHuman-  , helpHuman, mainMenuHuman, macroHuman-    -- * Commands specific to targeting-  , moveCursorHuman, tgtFloorHuman, tgtEnemyHuman-  , tgtUnknownHuman, tgtItemHuman, tgtStairHuman, tgtAscendHuman-  , epsIncrHuman, tgtClearHuman, cancelHuman, acceptHuman-    -- * Helper definitions-  , floorItemOverlay, itemOverlay-  , pickLeader, lookAt-  ) where---- Cabal-import qualified Paths_LambdaHack as Self (version)--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Function-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Monoid-import Data.Ord-import Data.Text (Text)-import qualified Data.Text as T-import Data.Version-import Game.LambdaHack.Frontend (frontendName)-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Client.Action-import Game.LambdaHack.Client.Binding-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Animation-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import qualified Game.LambdaHack.Common.HumanCmd as HumanCmd-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Key as K-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-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.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.TileKind--failWith :: MonadClientUI m => Msg -> m Slideshow-failWith msg = do-  modifyClient $ \cli -> cli {slastKey = Nothing}-  stopPlayBack-  assert (not $ T.null msg) $ promptToSlideshow msg---- * GameDifficultyCycle--gameDifficultyCycle :: MonadClientUI m => m ()-gameDifficultyCycle = do-  DebugModeCli{sdifficultyCli} <- getsClient sdebugCli-  let d = if sdifficultyCli <= -4 then 4 else sdifficultyCli - 1-  modifyClient $ \cli -> cli {sdebugCli = (sdebugCli cli) {sdifficultyCli = d}}-  msgAdd $ "Next game difficulty set to" <+> tshow (5 - d) <> "."---- * PickLeader--pickLeaderHuman :: MonadClientUI m => Int -> m Slideshow-pickLeaderHuman k = do-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  s <- getState-  case tryFindHeroK s side k of-    _ | isSpawnFact fact -> failWith "spawners cannot manually change leaders"-    Nothing -> failWith "No such member of the party."-    Just (aid, _) -> do-      void $ pickLeader aid-      return mempty---- * MemberCycle---- | Switches current member to the next on the level, if any, wrapping.-memberCycleHuman :: MonadClientUI m => m Slideshow-memberCycleHuman = do-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  leader <- getLeaderUI-  body <- getsState $ getActorBody leader-  hs <- partyAfterLeader leader-  case filter (\(_, b) -> blid b == blid body) hs of-    _ | isSpawnFact fact -> failWith "spawners cannot manually change leaders"-    [] -> failWith "Cannot pick any other member on this level."-    (np, b) : _ -> do-      success <- pickLeader np-      assert (success `blame` "same leader" `twith` (leader, np, b)) skip-      return mempty--partyAfterLeader :: MonadActionRO 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 => ActorId -> m Bool-pickLeader actor = do-  leader <- getLeaderUI-  stgtMode <- getsClient stgtMode-  if leader == actor-    then return False -- already picked-    else do-      pbody <- getsState $ getActorBody actor-      assert (not (bproj pbody) `blame` "projectile chosen as the leader"-                                `twith` (actor, pbody)) skip-      -- Even if it's already the leader, give his proper name, not 'you'.-      let subject = partActor pbody-      msgAdd $ makeSentence [subject, "picked as a leader"]-      -- Update client state.-      s <- getState-      modifyClient $ updateLeader actor 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) actor ""-      msgAdd lookMsg-      return True---- * MemberBack---- | Switches current member to the previous in the whole dungeon, wrapping.-memberBackHuman :: MonadClientUI m => m Slideshow-memberBackHuman = do-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  leader <- getLeaderUI-  hs <- partyAfterLeader leader-  case reverse hs of-    _ | isSpawnFact fact -> failWith "spawners cannot manually change leaders"-    [] -> failWith "No other member in the party."-    (np, b) : _ -> do-      success <- pickLeader np-      assert (success `blame` "same leader" `twith` (leader, np, b)) skip-      return mempty---- * Inventory---- TODO: When inventory is displayed, let TAB switch the leader (without--- announcing that) and show the inventory of the new leader (unless--- we have just a single inventory in the future).--- | Display inventory-inventoryHuman :: MonadClientUI m => m Slideshow-inventoryHuman = do-  leader <- getLeaderUI-  subject <- partAidLeader leader-  bag <- getsState $ getActorBag leader-  invRaw <- getsState $ getActorInv leader-  if EM.null bag-    then promptToSlideshow $ makeSentence-      [ MU.SubjectVerbSg subject "be"-      , "not carrying anything" ]-    else do-      let blurb = makePhrase-            [MU.Capitalize $ MU.SubjectVerbSg subject "be carrying:"]-          inv = EM.filter (`EM.member` bag) invRaw-      io <- itemOverlay bag inv-      overlayToSlideshow blurb io---- * 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 = do-  mleader <- getsClient _sleader-  case mleader of-    Nothing -> failWith "no leader picked, cannot select"-    Just leader -> do-      body <- getsState $ getActorBody leader-      wasMemeber <- getsClient $ ES.member leader . sselected-      let upd = if wasMemeber-                then ES.delete leader  -- already selected, deselect instead-                else ES.insert leader-      modifyClient $ \cli -> cli {sselected = upd $ sselected cli}-      let subject = partActor body-      msgAdd $ makeSentence [subject, if wasMemeber-                                      then "deselected"-                                      else "selected"]-      return mempty---- * SelectNone--selectNoneHuman :: (MonadClientUI m, MonadClient m) => m ()-selectNoneHuman = do-  side <- getsClient sside-  lidV <- viewedLevel-  oursAssocs <- getsState $ actorNotProjAssocs (== side) lidV-  let ours = ES.fromList $ map fst oursAssocs-  oldSel <- getsClient sselected-  let wasNone = ES.null $ ES.intersection ours oldSel-      upd = if wasNone-            then ES.union  -- already all deselected; select all instead-            else ES.difference-  modifyClient $ \cli -> cli {sselected = upd (sselected cli) ours}-  let subject = "all party members on the level"-  msgAdd $ makeSentence [subject, if wasNone-                                  then "selected"-                                  else "deselected"]---- * Clear---- | Clear current messages, show the next screen if any.-clearHuman :: Monad m => m ()-clearHuman = return ()---- * Repeat---- Note that walk followed by repeat should not be equivalent to run,--- because the player can really use a command that does not stop--- at terrain change or when walking over items.-repeatHuman :: MonadClient m => Int -> m ()-repeatHuman n = do-  (_, seqPrevious, k) <- getsClient slastRecord-  let macro = concat $ replicate n $ reverse seqPrevious-  modifyClient $ \cli -> cli {slastPlay = macro ++ slastPlay cli}-  let slastRecord = ([], [], if k == 0 then 0 else maxK)-  modifyClient $ \cli -> cli {slastRecord}--maxK :: Int-maxK = 100---- * Record--recordHuman :: MonadClientUI m => m Slideshow-recordHuman = do-  modifyClient $ \cli -> cli {slastKey = Nothing}-  (_seqCurrent, seqPrevious, k) <- getsClient slastRecord-  case k of-    0 -> do-      let slastRecord = ([], [], maxK)-      modifyClient $ \cli -> cli {slastRecord}-      promptToSlideshow $ "Macro will be recorded for up to"-                          <+> tshow maxK <+> "steps."-    _ -> do-      let slastRecord = (seqPrevious, [], 0)-      modifyClient $ \cli -> cli {slastRecord}-      promptToSlideshow $ "Macro recording interrupted after"-                          <+> tshow (maxK - k - 1) <+> "steps."---- * History--historyHuman :: MonadClientUI m => m Slideshow-historyHuman = do-  history <- getsClient shistory-  arena <- getArenaUI-  local <- getsState $ getLocalTime arena-  global <- getsState stime-  let  msg = makeSentence-        [ "You survived for"-        , MU.CarWs (global `timeFit` timeTurn) "half-second turn"-        , "(this level:"-        , MU.Text (tshow (local `timeFit` timeTurn)) MU.:> ")" ]-        <+> "Past messages:"-  overlayToBlankSlideshow msg $ renderHistory history---- * MarkVision, MarkSmell, MarkSuspect--markVisionHuman :: MonadClientUI m => m ()-markVisionHuman = do-  modifyClient toggleMarkVision-  cur <- getsClient smarkVision-  msgAdd $ "Visible area display toggled" <+> if cur then "on." else "off."--markSmellHuman :: MonadClientUI m => m ()-markSmellHuman = do-  modifyClient toggleMarkSmell-  cur <- getsClient smarkSmell-  msgAdd $ "Smell display toggled" <+> if cur then "on." else "off."--markSuspectHuman :: MonadClientUI m => m ()-markSuspectHuman = do-  -- BFS takes suspect tiles into account depending on @smarkSuspect@,-  -- so we need to invalidate the BFS data caches.-  modifyClient $ \cli -> cli {sbfsD = EM.empty}-  modifyClient toggleMarkSuspect-  cur <- getsClient smarkSuspect-  msgAdd $ "Suspect terrain display toggled" <+> if cur then "on." else "off."---- * Help---- | Display command help.-helpHuman :: MonadClientUI m => m Slideshow-helpHuman = do-  keyb <- askBinding-  return $! keyHelp keyb---- * MainMenu---- TODO: merge with the help screens better--- | Display the main menu.-mainMenuHuman :: MonadClientUI m => m Slideshow-mainMenuHuman = do-  Kind.COps{corule} <- getsState scops-  Binding{brevMap, bcmdList} <- askBinding-  scurDifficulty <- getsClient scurDifficulty-  DebugModeCli{sdifficultyCli} <- getsClient sdebugCli-  let stripFrame t = map (T.tail . T.init) $ tail . init $ T.lines t-      pasteVersion art =-        let pathsVersion = rpathsVersion $ Kind.stdRuleset corule-            version = " Version " ++ showVersion pathsVersion-                      ++ " (frontend: " ++ frontendName-                      ++ ", engine: LambdaHack " ++ showVersion Self.version-                      ++ ") "-            versionLen = length version-        in init art ++ [take (80 - versionLen) (last art) ++ version]-      kds =  -- key-description pairs-        let showKD cmd km = (K.showKM km, HumanCmd.cmdDescription cmd)-            revLookup cmd = maybe ("", "") (showKD cmd) $ M.lookup cmd brevMap-            cmds = [ (K.showKM km, desc)-                   | (km, (desc, HumanCmd.CmdMenu, cmd)) <- bcmdList,-                     cmd /= HumanCmd.GameDifficultyCycle ]-        in [ (fst (revLookup HumanCmd.Cancel), "back to playing")-           , (fst (revLookup HumanCmd.Accept), "see more help") ]-           ++ cmds-           ++ [ (fst ( revLookup HumanCmd.GameDifficultyCycle)-                     , "next game difficulty"-                       <+> tshow (5 - sdifficultyCli)-                       <+> "(current"-                       <+> tshow (5 - scurDifficulty) <> ")" ) ]-      bindingLen = 25-      bindings =  -- key bindings to display-        let fmt (k, d) = T.justifyLeft bindingLen ' '-                         $ T.justifyLeft 7 ' ' k <> " " <> d-        in map fmt kds-      overwrite =  -- overwrite the art with key bindings-        let over [] line = ([], T.pack line)-            over bs@(binding : bsRest) line =-              let (prefix, lineRest) = break (=='{') line-                  (braces, suffix)   = span  (=='{') lineRest-              in if length braces == 25-                 then (bsRest, T.pack prefix <> binding-                               <> T.drop (T.length binding - bindingLen)-                                         (T.pack suffix))-                 else (bs, T.pack line)-        in snd . mapAccumL over bindings-      mainMenuArt = rmainMenuArt $ Kind.stdRuleset corule-      menuOverlay =  -- TODO: switch to Text and use T.justifyLeft-        overwrite $ pasteVersion $ map T.unpack $ stripFrame mainMenuArt-  case menuOverlay of-    [] -> assert `failure` "empty Main Menu overlay" `twith` mainMenuArt-    hd : tl -> overlayToBlankSlideshow hd (toOverlay tl)-               -- TODO: keys don't work if tl/=[]---- * Macro--macroHuman :: MonadClient m => [String] -> m ()-macroHuman kms =-  modifyClient $ \cli -> cli {slastPlay = map K.mkKM kms ++ slastPlay cli}---- * MoveCursor--moveCursorHuman :: MonadClientUI m => Vector -> Int -> m Slideshow-moveCursorHuman dir n = do-  leader <- getLeaderUI-  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 failWith "never mind"-  else do-    let tgt = case scursor of-          TVector{} -> TVector $ displacement lpos newPos-          _ -> TPoint lidV newPos-    modifyClient $ \cli -> cli {scursor = tgt}-    doLook---- TODO: probably move somewhere (Level?)--- | Produces a textual description of the terrain and items at an already--- explored position. Mute for unknown positions.--- The detailed variant is for use in the targeting mode.-lookAt :: MonadClientUI m-       => Bool       -- ^ detailed?-       -> Text       -- ^ how to start tile description-       -> Bool       -- ^ can be seen right now?-       -> Point      -- ^ position to describe-       -> ActorId    -- ^ the actor that looks-       -> Text       -- ^ an extra sentence to print-       -> m Text-lookAt detailed tilePrefix canSee pos aid msg = do-  Kind.COps{coitem, cotile=cotile@Kind.Ops{okind}} <- getsState scops-  lidV <- viewedLevel-  lvl <- getLevel lidV-  subject <- partAidLeader aid-  s <- getState-  let is = lvl `atI` pos-      verb = MU.Text $ if canSee then "notice" else "remember"-  disco <- getsClient sdisco-  let nWs (iid, k) = partItemWs coitem disco k (getItemBody iid s)-      isd = case detailed of-              _ | EM.size is == 0 -> ""-              _ | EM.size is <= 2 ->-                makeSentence [ MU.SubjectVerbSg subject verb-                             , MU.WWandW $ map nWs $ EM.assocs is]-              True -> "Objects:"-              _ -> "Objects here."-      tile = lvl `at` pos-      obscured | tile /= hideTile cotile lvl pos = "partially obscured"-               | otherwise = ""-      tileText = obscured <+> tname (okind tile)-      tilePart | T.null tilePrefix = MU.Text tileText-               | otherwise = MU.AW $ MU.Text tileText-      tileDesc = [MU.Text tilePrefix, tilePart]-  if not (null (Tile.causeEffects cotile tile)) then-    return $! makeSentence ("activable:" : tileDesc)-              <+> msg <+> isd-  else if detailed then-    return $! makeSentence tileDesc-              <+> msg <+> isd-  else return $! msg <+> isd---- | Perform look around in the current position of the cursor.--- Assumes targeting mode and so assumes that a leader is picked.-doLook :: MonadClientUI m => m Slideshow-doLook = do-  leader <- getLeaderUI-  stgtMode <- getsClient stgtMode-  let lidV = maybe (assert `failure` leader) tgtLevelId stgtMode-  lvl <- getLevel lidV-  cursorPos <- cursorToPos-  per <- getPerFid lidV-  b <- getsState $ getActorBody leader-  let p = fromMaybe (bpos b) cursorPos-      canSee = ES.member p (totalVisible per)-  inhabitants <- if canSee-                 then getsState $ posToActors p lidV-                 else return []-  aims <- actorAimsPos leader p-  let enemyMsg = case inhabitants of-        [] -> ""-        _ -> -- Even if it's the leader, give his proper name, not 'you'.-             let subjects = map (partActor . snd . fst) inhabitants-                 subject = MU.WWandW subjects-                 verb = "be here"-             in makeSentence [MU.SubjectVerbSg subject verb]-      vis | not canSee = "you cannot see"-          | not aims = "you cannot penetrate"-          | otherwise = "you see"-  -- Show general info about current position.-  lookMsg <- lookAt True vis canSee p leader enemyMsg-  modifyClient $ \cli -> cli {slastKey = Nothing}-  -- Check if there's something lying around at current position.-  let is = lvl `atI` p-  if EM.size is <= 2 then-    promptToSlideshow lookMsg-  else do-    io <- floorItemOverlay is-    overlayToSlideshow lookMsg io---- | Create a list of item names.-floorItemOverlay :: MonadClient m => ItemBag -> m Overlay-floorItemOverlay bag = do-  Kind.COps{coitem} <- getsState scops-  s <- getState-  disco <- getsClient sdisco-  let is = zip (EM.assocs bag) (allLetters ++ repeat (InvChar ' '))-      pr ((iid, k), l) =-         makePhrase [ letterLabel l-                    , partItemWs coitem disco k (getItemBody iid s) ]-         <> " "-  return $! toOverlay $ map pr is---- | Create a list of item names.-itemOverlay :: MonadClient m => ItemBag -> ItemInv -> m Overlay-itemOverlay bag inv = do-  Kind.COps{coitem} <- getsState scops-  s <- getState-  disco <- getsClient sdisco-  let pr (l, iid) =-         makePhrase [ letterLabel l-                    , partItemWs coitem disco (bag EM.! iid)-                                 (getItemBody iid s) ]-         <> " "-  return $! toOverlay $ map pr $ EM.assocs inv---- * TgtFloor---- | Cycle targeting mode. Do not change position of the cursor,--- switch among things at that position.-tgtFloorHuman :: MonadClientUI m => m Slideshow-tgtFloorHuman = do-  lidV <- viewedLevel-  leader <- getLeaderUI-  lpos <- getsState $ bpos . getActorBody leader-  cursorPos <- cursorToPos-  scursor <- getsClient scursor-  stgtMode <- getsClient stgtMode-  side <- getsClient sside-  fact <- getsState $ (EM.! side) . sfactionD-  bfs <- getCacheBfs leader-  bsAll <- getsState $ actorAssocs (const True) lidV-  let cursor = fromMaybe lpos cursorPos-      tgt = case scursor of-        _ | isNothing stgtMode ->  -- first key press: keep target-          scursor-        TEnemy a False -> TEnemy a True-        TEnemy{} -> TPoint lidV cursor-        TEnemyPos{} -> TPoint lidV cursor-        TPoint{} -> TVector $ displacement lpos cursor-        TVector{} ->-          let isEnemy b = isAtWar fact (bfid b)-                          && not (bproj b)-                          && posAimsPos bfs lpos (bpos b)-          -- For projectiles, we pick here the first that would be picked-          -- by '*', so that all other projectiles on the tile come next,-          -- without any intervening actors from other tiles.-          in case find (\(_, m) -> Just (bpos m) == cursorPos) bsAll of-            Just (im, m) | isEnemy m -> TEnemy im False-            Just (im, _) -> TEnemy im True-            Nothing -> TPoint lidV cursor-  modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV}-  doLook---- * TgtEnemy--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-  bfs <- getCacheBfs leader-  bsAll <- getsState $ actorAssocs (const True) lidV-  let ordPos (_, b) = (chessDist lpos $ bpos b, bpos b)-      dbs = sortBy (comparing ordPos) bsAll-      pickUnderCursor =  -- switch to the enemy under cursor, if any-        let i = fromMaybe (-1)-                $ findIndex ((== cursorPos) . Just . bpos . snd) dbs-        in splitAt i dbs-      (permitAnyActor, (lt, gt)) = case scursor of-            TEnemy a permit | isJust stgtMode ->  -- pick next enemy-              let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs-              in (permit, splitAt (i + 1) dbs)-            TEnemy a permit ->  -- first key press, retarget old enemy-              let i = fromMaybe (-1) $ findIndex ((== a) . fst) dbs-              in (permit, splitAt i dbs)-            TEnemyPos _ _ _ permit -> (permit, pickUnderCursor)-            _ -> (False, pickUnderCursor)  -- the sensible default is only-foes-      gtlt = gt ++ lt-      isEnemy b = isAtWar fact (bfid b)-                  && not (bproj b)-                  && posAimsPos bfs lpos (bpos b)-      lf = filter (isEnemy . snd) gtlt-      tgt | permitAnyActor = case gtlt of-        (a, _) : _ -> TEnemy a True-        [] -> scursor  -- no actors in sight, stick to last target-          | otherwise = case lf of-        (a, _) : _ -> TEnemy a False-        [] -> scursor  -- no seen foes in sight, stick to last target-  -- Register the chosen enemy, to pick another on next invocation.-  modifyClient $ \cli -> cli {scursor = tgt, stgtMode = Just $ TgtMode lidV}-  doLook---- * TgtUnknown--tgtUnknownHuman :: MonadClientUI m => m Slideshow-tgtUnknownHuman = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  mpos <- closestUnknown leader-  case mpos of-    Nothing -> failWith "no more unknown spots left"-    Just p -> do-      let tgt = TPoint (blid b) p-      modifyClient $ \cli -> cli {scursor = tgt}-      return mempty---- * TgtItem--tgtItemHuman :: MonadClientUI m => m Slideshow-tgtItemHuman = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  items <- closestItems leader-  case items of-    [] -> failWith "no more items remembered or visible"-    (_, (p, _)) : _ -> do-      let tgt = TPoint (blid b) p-      modifyClient $ \cli -> cli {scursor = tgt}-      return mempty---- * TgtStair--tgtStairHuman :: MonadClientUI m => Bool -> m Slideshow-tgtStairHuman up = do-  leader <- getLeaderUI-  b <- getsState $ getActorBody leader-  stairs <- closestTriggers (Just up) False leader-  case stairs of-    [] -> failWith $ "no stairs"-                     <+> if up then "up" else "down"-    p : _ -> do-      let tgt = TPoint (blid b) p-      modifyClient $ \cli -> cli {scursor = tgt}-      return mempty---- * TgtAscend---- | Change the displayed level in targeting mode to (at most)--- k levels shallower. Enters targeting mode, if not already in one.-tgtAscendHuman :: MonadClientUI m => Int -> m Slideshow-tgtAscendHuman k = do-  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops-  dungeon <- getsState sdungeon-  scursorOld <- getsClient scursor-  cursorPos <- cursorToPos-  lidV <- viewedLevel-  lvl <- getLevel lidV-  let rightStairs = case cursorPos of-        Nothing -> Nothing-        Just cpos ->-          let tile = lvl `at` cpos-          in if Tile.hasFeature cotile (F.Cause $ Effect.Ascend k) tile-             then Just cpos-             else Nothing-  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-      -- Do not freely reveal the other end of the stairs.-      let ascDesc (F.Cause (Effect.Ascend _)) = True-          ascDesc _ = False-          scursor =-            if any ascDesc $ tfeature $ okind (lvl `at` npos)-            then TPoint nln npos  -- already known as an exit, focus on it-            else scursorOld  -- unknown, do not reveal-      modifyClient $ \cli -> cli {scursor, stgtMode = Just (TgtMode nln)}-      doLook-    Nothing ->  -- no stairs in the right direction-      case ascendInBranch dungeon k lidV of-        [] -> failWith "no more levels in this direction"-        nln : _ -> do-          modifyClient $ \cli -> cli {stgtMode = Just (TgtMode nln)}-          doLook---- * EpsIncr---- | Tweak the @eps@ parameter of the targeting digital line.-epsIncrHuman :: 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 failWith "never mind"  -- no visual feedback, so no sense---- * TgtClear--tgtClearHuman :: MonadClient m => m ()-tgtClearHuman = do-  mleader <- getsClient _sleader-  case mleader of-    Nothing -> return ()-    Just leader -> do-      tgt <- getsClient $ getTarget leader-      case tgt of-        Just _ -> modifyClient $ updateTarget leader (const Nothing)-        Nothing -> do-          scursorOld <- getsClient scursor-          b <- getsState $ getActorBody leader-          let scursor = case scursorOld of-                TEnemy _ permit -> TEnemy leader permit-                TEnemyPos _ _ _ permit -> TEnemy leader permit-                TPoint{} -> TPoint (blid b) (bpos b)-                TVector{} -> TVector (Vector 0 0)-          modifyClient $ \cli -> cli {scursor}---- * Cancel---- | Cancel something, e.g., targeting mode, resetting the cursor--- to the position of the leader. Chosen target is not invalidated.-cancelHuman :: MonadClientUI m => m Slideshow -> m Slideshow-cancelHuman h = do-  stgtMode <- getsClient stgtMode-  if isJust stgtMode-    then targetReject-    else h  -- nothing to cancel right now, treat this as a command invocation---- | End targeting mode, rejecting the current position.-targetReject :: MonadClientUI m => m Slideshow-targetReject = do-  modifyClient $ \cli -> cli {stgtMode = Nothing}-  failWith "targeting canceled"---- * Accept---- | Accept something, e.g., targeting mode, keeping cursor where it was.--- Or perform the default action, if nothing needs accepting.-acceptHuman :: MonadClientUI m => m Slideshow -> m Slideshow-acceptHuman h = do-  stgtMode <- getsClient stgtMode-  if isJust stgtMode-    then do-      targetAccept-      return mempty-    else h  -- nothing to accept right now, treat this as a command invocation---- | End targeting mode, accepting the current position.-targetAccept :: MonadClientUI m => m ()-targetAccept = do-  endTargeting-  endTargetingMsg-  modifyClient $ \cli -> cli {stgtMode = Nothing}---- | End targeting mode, accepting the current position.-endTargeting :: MonadClientUI m => m ()-endTargeting = do-  leader <- getLeaderUI-  scursor <- getsClient scursor-  modifyClient $ updateTarget leader $ const $ Just scursor--endTargetingMsg :: MonadClientUI m => m ()-endTargetingMsg = do-  leader <- getLeaderUI-  targetMsg <- targetDescLeader leader-  subject <- partAidLeader leader-  msgAdd $ makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg]
− Game/LambdaHack/Client/HumanSem.hs 
@@ -1,81 +0,0 @@--- | Semantics of human player commands.-module Game.LambdaHack.Client.HumanSem-  ( cmdHumanSem-  ) where--import Data.Monoid--import Game.LambdaHack.Client.Action-import Game.LambdaHack.Client.HumanGlobal-import Game.LambdaHack.Client.HumanLocal-import Game.LambdaHack.Common.HumanCmd-import Game.LambdaHack.Common.ServerCmd---- | The semantics of human player commands in terms of the @Action@ monad.--- Decides if the action takes time and what action to perform.--- Some time cosuming commands are enabled in targeting mode, but cannot be--- invoked in targeting mode on a remote level (level different than--- the level of the leader).-cmdHumanSem :: MonadClientUI m => HumanCmd -> m (SlideOrCmd CmdSer)-cmdHumanSem cmd = do-  if noRemoteHumanCmd cmd then do-    -- If in targeting mode, check if the current level is the same-    -- as player level and refuse performing the action otherwise.-    arena <- getArenaUI-    lidV <- viewedLevel-    if (arena /= lidV) then-      failWith $ "command disabled on a remote level, press ESC to switch back"-    else cmdAction cmd-  else cmdAction cmd---- | Compute the basic action for a command and mark whether it takes time.-cmdAction :: MonadClientUI m => HumanCmd -> m (SlideOrCmd CmdSer)-cmdAction cmd = case cmd of-  Move v -> fmap (fmap CmdTakeTimeSer) $ moveRunHuman False v-  Run v -> fmap (fmap CmdTakeTimeSer) $ moveRunHuman True v-  Wait -> fmap Right $ fmap CmdTakeTimeSer waitHuman-  Pickup -> fmap (fmap CmdTakeTimeSer) pickupHuman-  Drop -> fmap (fmap CmdTakeTimeSer) dropHuman-  Project ts -> fmap (fmap CmdTakeTimeSer) $ projectHuman ts-  Apply ts -> fmap (fmap CmdTakeTimeSer) $ applyHuman ts-  AlterDir ts -> fmap (fmap CmdTakeTimeSer) $ alterDirHuman ts-  TriggerTile ts -> fmap (fmap CmdTakeTimeSer) $ triggerTileHuman ts-  StepToTarget -> fmap (fmap CmdTakeTimeSer) stepToTargetHuman-  Resend -> fmap (fmap CmdTakeTimeSer) resendHuman--  GameRestart t -> gameRestartHuman t-  GameExit -> gameExitHuman-  GameSave -> fmap Right gameSaveHuman--  GameDifficultyCycle -> addNoSlides gameDifficultyCycle-  PickLeader k -> fmap Left $ pickLeaderHuman k-  MemberCycle -> fmap Left memberCycleHuman-  MemberBack -> fmap Left memberBackHuman-  Inventory -> fmap Left inventoryHuman-  SelectActor -> fmap Left selectActorHuman-  SelectNone -> addNoSlides selectNoneHuman-  Clear -> addNoSlides clearHuman-  Repeat n -> addNoSlides $ repeatHuman n-  Record -> fmap Left recordHuman-  History -> fmap Left historyHuman-  MarkVision -> addNoSlides markVisionHuman-  MarkSmell -> addNoSlides markSmellHuman-  MarkSuspect -> addNoSlides markSuspectHuman-  Help -> fmap Left helpHuman-  MainMenu -> fmap Left mainMenuHuman-  Macro _ kms -> addNoSlides $ macroHuman kms--  MoveCursor v k -> fmap Left $ moveCursorHuman v k-  TgtFloor -> fmap Left tgtFloorHuman-  TgtEnemy -> fmap Left tgtEnemyHuman-  TgtUnknown -> fmap Left tgtUnknownHuman-  TgtItem -> fmap Left tgtItemHuman-  TgtStair up -> fmap Left $ tgtStairHuman up-  TgtAscend k -> fmap Left $ tgtAscendHuman k-  EpsIncr b -> fmap Left $ epsIncrHuman b-  TgtClear -> addNoSlides tgtClearHuman-  Cancel -> fmap Left $ cancelHuman mainMenuHuman-  Accept -> fmap Left $ acceptHuman helpHuman--addNoSlides :: Monad m => m () -> m (SlideOrCmd CmdSer)-addNoSlides cmdCli = cmdCli >> return (Left mempty)
+ Game/LambdaHack/Client/ItemSlot.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Item slots for UI and AI item collections.+-- TODO: document+module Game.LambdaHack.Client.ItemSlot+  ( ItemSlots, SlotChar(..)+  , allSlots, slotLabel, slotRange, assignSlot+  ) where++import Data.Binary+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.Text (Text)+import qualified Data.Text as T+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.State++newtype SlotChar = SlotChar {slotChar :: Char}+  deriving (Show, Eq, Binary)++instance Ord SlotChar where+  compare x y = compare (fromEnum x) (fromEnum y)++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)++type ItemSlots = (EM.EnumMap SlotChar ItemId, IM.IntMap ItemId)++slotRange :: [SlotChar] -> Text+slotRange ls =+  sectionBy (sort ls) Nothing+ where+  succSlot c d = ord (slotChar d) - ord (slotChar c) == 1++  sectionBy []     Nothing       = T.empty+  sectionBy []     (Just (c, d)) = finish (c,d)+  sectionBy (x:xs) Nothing       = sectionBy xs (Just (x, x))+  sectionBy (x:xs) (Just (c, d))+    | succSlot d x               = sectionBy xs (Just (c, x))+    | otherwise                  = finish (c,d) <> sectionBy xs (Just (x, x))++  finish (c, d) | c == d         = T.pack [slotChar c]+                | succSlot c d   = T.pack [slotChar c, slotChar d]+                | otherwise      = T.pack [slotChar c, '-', slotChar d]++allSlots :: [SlotChar]+allSlots = map SlotChar $ ['a'..'z'] ++ ['A'..'Z']++-- | 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+ where+  candidates = take (length allSlots)+               $ drop (1 + fromJust (elemIndex lastSlot allSlots))+               $ cycle allSlots+  onPerson = maybe (sharedAllOwnedFid fid s)+                   (\body -> sharedAllOwned body s)+                   mbody+  onGroud = maybe EM.empty+                  (\body -> sdungeon s EM.! blid body `atI` bpos body)+                  mbody+  inBags = ES.unions $ map EM.keysSet [onPerson, onGroud]+  f l = maybe True (`ES.notMember` inBags) $ EM.lookup l letterSlots+  free = filter f candidates+  g l = maybe True (`ES.notMember` inBags) $ IM.lookup l numberSlots+  freeNumbers = filter g [0..]++slotLabel :: Either SlotChar Int -> MU.Part+slotLabel (Left c) = MU.String [slotChar c]+slotLabel Right{} = "0"
+ Game/LambdaHack/Client/Key.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Frontend-independent keyboard input operations.+module Game.LambdaHack.Client.Key+  ( Key(..), showKey, handleDir, dirAllKey+  , moveBinding, mkKM, keyTranslate+  , Modifier(..), KM(..), showKM+  , escKM, spaceKM, pgupKM, pgdnKM+  ) where++import Control.Exception.Assert.Sugar+import Data.Binary+import qualified Data.Char as Char+import Data.Text (Text)+import qualified Data.Text as T+import GHC.Generics (Generic)+import Prelude hiding (Left, Right)++import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Vector++-- | Frontend-independent datatype to represent keys.+data Key =+    Esc+  | Return+  | Space+  | Tab+  | BackTab+  | BackSpace+  | PgUp+  | PgDn+  | Left+  | Right+  | Up+  | Down+  | End+  | Begin+  | Home+  | KP !Char      -- ^ a keypad key for a character (digits and operators)+  | Char !Char    -- ^ a single printable character+  | Unknown !Text -- ^ an unknown key, registered to warn the user+  deriving (Read, Ord, Eq, Generic)++instance Binary Key++-- | Our own encoding of modifiers. Incomplete.+data Modifier =+    NoModifier+  | Control+  deriving (Read, Ord, Eq, Generic)++instance Binary Modifier++data KM = KM {modifier :: !Modifier, key :: !Key}+  deriving (Read, Ord, Eq, Generic)++instance Show KM where+  show = T.unpack . showKM++instance Binary KM++-- Common and terse names for keys.+showKey :: Key -> Text+showKey (Char c) = T.singleton c+showKey Esc      = "ESC"+showKey Return   = "RET"+showKey Space    = "SPACE"+showKey Tab      = "TAB"+showKey BackTab  = "SHIFT-TAB"+showKey BackSpace = "BACKSPACE"+showKey Up       = "UP"+showKey Down     = "DOWN"+showKey Left     = "LEFT"+showKey Right    = "RIGHT"+showKey Home     = "HOME"+showKey End      = "END"+showKey PgUp     = "PGUP"+showKey PgDn     = "PGDOWN"+showKey Begin    = "BEGIN"+showKey (KP c)   = "KEYPAD_" <> T.singleton c+showKey (Unknown s) = s++-- | Show a key with a modifier, if any.+showKM :: KM -> Text+showKM KM{modifier=Control, key} = "CTRL-" <> showKey key+showKM KM{modifier=NoModifier, key} = showKey key++escKM :: KM+escKM = KM {modifier = NoModifier, key = Esc}++spaceKM :: KM+spaceKM = KM {modifier = NoModifier, key = Space}++pgupKM :: KM+pgupKM = KM {modifier = NoModifier, key = PgUp}++pgdnKM :: KM+pgdnKM = KM {modifier = NoModifier, key = PgDn}++dirKeypadKey :: [Key]+dirKeypadKey = [Home, Up, PgUp, Right, PgDn, Down, End, Left]++dirKeypadShiftChar :: [Char]+dirKeypadShiftChar = ['7', '8', '9', '6', '3', '2', '1', '4']++dirKeypadShiftKey :: [Key]+dirKeypadShiftKey = map KP dirKeypadShiftChar++dirLaptopKey :: [Key]+dirLaptopKey = map Char ['7', '8', '9', 'o', 'l', 'k', 'j', 'u']++dirLaptopShiftKey :: [Key]+dirLaptopShiftKey = map Char ['&', '*', '(', 'O', 'L', 'K', 'J', 'U']++dirViChar :: [Char]+dirViChar = ['y', 'k', 'u', 'l', 'n', 'j', 'b', 'h']++dirViKey :: [Key]+dirViKey = map Char dirViChar++dirViShiftKey :: [Key]+dirViShiftKey = map (Char . Char.toUpper) dirViChar++dirAllKey :: Bool -> Bool -> [Key]+dirAllKey configVi configLaptop = dirKeypadKey ++ if configVi+                                                  then dirViKey+                                                  else if configLaptop+                                                       then dirLaptopKey+                                                       else []++-- | Configurable event handler for the direction keys.+-- Used for directed commands such as close door.+handleDir :: Bool -> Bool -> KM -> (Vector -> a) -> a -> a+handleDir configVi configLaptop KM{modifier=NoModifier, key} h k =+  let assocs = zip (dirAllKey configVi configLaptop) $ moves ++ moves+  in maybe k h (lookup key assocs)+handleDir _ _ _ _ k = k++-- | Binding of both sets of movement keys.+moveBinding :: Bool -> Bool -> (Vector -> a) -> (Vector -> a)+            -> [(KM, a)]+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)+      mapRun modifier keys =+        map (assign run) (zip (zipWith KM (repeat modifier) keys) moves)+      dirOtherKey | configVi = dirViKey+                  | configLaptop = dirLaptopKey+                  | otherwise = []+      dirOtherShiftKey | configVi = dirViShiftKey+                       | configLaptop = dirLaptopShiftKey+                       | otherwise = []+  in mapMove NoModifier dirKeypadKey+     ++ mapMove NoModifier dirOtherKey+     ++ mapRun NoModifier dirKeypadShiftKey+     ++ mapRun NoModifier dirOtherShiftKey+     ++ mapRun Control dirKeypadKey+     ++ mapRun Control dirKeypadShiftKey+     ++ mapRun Control (map Char dirKeypadShiftChar)++mkKM :: String -> KM+mkKM s = let mkKey sk =+               case keyTranslate sk of+                 Unknown _ ->+                   assert `failure` "unknown key" `twith` s+                 key -> key+         in case s of+           ('C':'T':'R':'L':'-':rest) -> KM {key=mkKey rest, modifier=Control}+           _ -> KM {key=mkKey s, modifier=NoModifier}++-- | Translate key from a GTK string description to our internal key type.+-- To be used, in particular, for the command bindings and macros+-- in the config file.+keyTranslate :: String -> Key+keyTranslate "less"          = Char '<'+keyTranslate "greater"       = Char '>'+keyTranslate "period"        = Char '.'+keyTranslate "colon"         = Char ':'+keyTranslate "semicolon"     = Char ';'+keyTranslate "comma"         = Char ','+keyTranslate "question"      = Char '?'+keyTranslate "dollar"        = Char '$'+keyTranslate "parenleft"     = Char '('+keyTranslate "parenright"    = Char ')'+keyTranslate "asterisk"      = Char '*'+keyTranslate "KP_Multiply"   = KP '*'+keyTranslate "slash"         = Char '/'+keyTranslate "KP_Divide"     = Char '/'+keyTranslate "backslash"     = Char '\\'+keyTranslate "underscore"    = Char '_'+keyTranslate "minus"         = Char '-'+keyTranslate "KP_Subtract"   = Char '-'+keyTranslate "plus"          = Char '+'+keyTranslate "KP_Add"        = Char '+'+keyTranslate "equal"         = Char '='+keyTranslate "bracketleft"   = Char '['+keyTranslate "bracketright"  = Char ']'+keyTranslate "braceleft"     = Char '{'+keyTranslate "braceright"    = Char '}'+keyTranslate "ampersand"     = Char '&'+keyTranslate "apostrophe"    = Char '\''+keyTranslate "Escape"        = Esc+keyTranslate "Return"        = Return+keyTranslate "space"         = Space+keyTranslate "Tab"           = Tab+keyTranslate "ISO_Left_Tab"  = BackTab+keyTranslate "BackSpace"     = BackSpace+keyTranslate "KP_Up"         = Up+keyTranslate "KP_Down"       = Down+keyTranslate "KP_Left"       = Left+keyTranslate "KP_Right"      = Right+keyTranslate "KP_Home"       = Home+keyTranslate "KP_End"        = End+keyTranslate "Page_Up"       = PgUp+keyTranslate "KP_Page_Up"    = PgUp+keyTranslate "Page_Down"     = PgDn+keyTranslate "KP_Page_Down"  = PgDn+keyTranslate "KP_Begin"      = Begin+keyTranslate "KP_Enter"      = Return+keyTranslate ['K','P','_',c] = KP c+keyTranslate [c]             = Char c+keyTranslate s               = Unknown $ T.pack s
− Game/LambdaHack/Client/LoopAction.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--- | The main loop of the client, processing human and computer player--- moves turn by turn.-module Game.LambdaHack.Client.LoopAction (loopAI, loopUI) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.Text as T--import Game.LambdaHack.Client.Action-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Animation-import Game.LambdaHack.Common.AtomicCmd-import Game.LambdaHack.Common.ClientCmd-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.RuleKind--initCli :: MonadClient m => DebugModeCli -> (State -> m ()) -> m Bool-initCli sdebugCli putSt = do-  -- Warning: state and client state are invalid here, e.g., sdungeon-  -- and sper are empty.-  cops <- getsState scops-  sconfigUI <- getsClient sconfigUI  -- config from file, not savegame-  modifyClient $ \cli -> cli {sdebugCli}-  restored <- restoreGame-  case restored of-    Just (s, cli) | not $ snewGameCli sdebugCli -> do  -- Restore the game.-      let sCops = updateCOps (const cops) s-      putSt sCops-      putClient cli {sdebugCli, sconfigUI}-      return True-    _ ->  -- First visit ever, use the initial state.-      return False--loopAI :: (MonadClientReadServer CmdClientAI m)-       => DebugModeCli -> (CmdClientAI -> m ()) -> m ()-loopAI sdebugCli cmdClientAISem = do-  side <- getsClient sside-  restored <- initCli sdebugCli-              $ \s -> cmdClientAISem $ CmdAtomicAI $ ResumeServerA s-  cmd1 <- readServer-  case (restored, cmd1) of-    (True, CmdAtomicAI ResumeA{}) -> return ()-    (True, CmdAtomicAI RestartA{}) -> return ()-    (False, CmdAtomicAI ResumeA{}) -> do-      removeServerSave-      error $ T.unpack $-        "Savefile of client" <+> tshow side-        <+> "not usable. Removing server savefile. Please restart now."-    (False, CmdAtomicAI RestartA{}) -> return ()-    _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1)-  cmdClientAISem cmd1-  -- State and client state now valid.-  debugPrint $ "AI client" <+> tshow side <+> "started."-  loop-  debugPrint $ "AI client" <+> tshow side <+> "stopped."- where-  loop = do-    cmd <- readServer-    cmdClientAISem cmd-    quit <- getsClient squit-    unless quit loop--loopUI :: (MonadClientUI m, MonadClientReadServer CmdClientUI m)-       => DebugModeCli -> (CmdClientUI -> m ()) -> m ()-loopUI sdebugCli cmdClientUISem = do-  Kind.COps{corule} <- getsState scops-  let title = rtitle $ Kind.stdRuleset corule-  side <- getsClient sside-  restored <- initCli sdebugCli-              $ \s -> cmdClientUISem $ CmdAtomicUI $ ResumeServerA s-  cmd1 <- readServer-  case (restored, cmd1) of-    (True, CmdAtomicUI ResumeA{}) -> do-      let msg = "Welcome back to" <+> title <> "."-      cmdClientUISem cmd1-      msgAdd msg-    (True, CmdAtomicUI RestartA{}) -> do-      let msg = "Starting a new" <+> title <+> "game."  -- ignore old savefile-      cmdClientUISem cmd1-      msgAdd msg-    (False, CmdAtomicUI ResumeA{}) -> do-      removeServerSave-      error $ T.unpack $-        "Savefile of client" <+> tshow side-        <+> "not usable. Removing server savefile. Please restart now."-    (False, CmdAtomicUI RestartA{}) -> do-      let msg = "Welcome to" <+> title <> "!"-      cmdClientUISem cmd1-      msgAdd msg-    _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1)-  -- State and client state now valid.-  debugPrint $ "UI client" <+> tshow side <+> "started."-  loop-  debugPrint $ "UI client" <+> tshow side <+> "stopped."- where-  loop = do-    cmd <- readServer-    cmdClientUISem cmd-    quit <- getsClient squit-    unless quit loop
+ Game/LambdaHack/Client/LoopClient.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE FlexibleContexts #-}+-- | The main loop of the client, processing human and computer player+-- moves turn by turn.+module Game.LambdaHack.Client.LoopClient (loopAI, loopUI) where++import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+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+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.MonadStateRead+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.Response+import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind++initCli :: MonadClient m => DebugModeCli -> (State -> m ()) -> m Bool+initCli sdebugCli putSt = do+  -- Warning: state and client state are invalid here, e.g., sdungeon+  -- and sper are empty.+  cops <- getsState scops+  modifyClient $ \cli -> cli {sdebugCli}+  restored <- restoreGame+  case restored of+    Just (s, cli) | not $ snewGameCli sdebugCli -> do  -- Restore the game.+      let sCops = updateCOps (const cops) s+      putSt sCops+      putClient cli {sdebugCli}+      return True+    _ -> do  -- First visit ever, use the initial state.+      -- But preserve the previous history, if any (--newGame).+      case restored of+        Just (_, cliR) -> modifyClient $ \cli -> cli {shistory = shistory cliR}+        Nothing -> return ()+      return False++loopAI :: ( MonadAtomic m+          , MonadClientReadResponse ResponseAI m+          , MonadClientWriteRequest RequestAI m )+       => DebugModeCli -> m ()+loopAI sdebugCli = do+  side <- getsClient sside+  restored <- initCli sdebugCli+              $ \s -> handleResponseAI $ RespUpdAtomicAI $ UpdResumeServer s+  cmd1 <- receiveResponse+  case (restored, cmd1) of+    (True, RespUpdAtomicAI UpdResume{}) -> return ()+    (True, RespUpdAtomicAI UpdRestart{}) -> return ()+    (False, RespUpdAtomicAI UpdResume{}) -> do+      removeServerSave+      error $ T.unpack $+        "Savefile of client" <+> tshow side+        <+> "not usable. Removing server savefile. Please restart now."+    (False, RespUpdAtomicAI UpdRestart{}) -> return ()+    _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1)+  handleResponseAI cmd1+  -- State and client state now valid.+  debugPrint $ "AI client" <+> tshow side <+> "started."+  loop+  debugPrint $ "AI client" <+> tshow side <+> "stopped."+ where+  loop = do+    cmd <- receiveResponse+    handleResponseAI cmd+    quit <- getsClient squit+    unless quit loop++loopUI :: ( MonadClientUI m+          , MonadAtomic m+          , MonadClientReadResponse ResponseUI m+          , MonadClientWriteRequest RequestUI m )+       => DebugModeCli -> m ()+loopUI sdebugCli = do+  Kind.COps{corule} <- getsState scops+  let title = rtitle $ Kind.stdRuleset corule+  side <- getsClient sside+  restored <- initCli sdebugCli+              $ \s -> handleResponseUI $ RespUpdAtomicUI $ UpdResumeServer s+  cmd1 <- receiveResponse+  case (restored, cmd1) of+    (True, RespUpdAtomicUI UpdResume{}) -> do+      mode <- getModeClient+      msgAdd $ mdesc mode+      handleResponseUI cmd1+    (True, RespUpdAtomicUI UpdRestart{}) -> do+      msgAdd $+        "Ignoring an old savefile and starting a new" <+> title <+> "game."+      handleResponseUI cmd1+    (False, RespUpdAtomicUI UpdResume{}) -> do+      removeServerSave+      error $ T.unpack $+        "Savefile of client" <+> tshow side+        <+> "not usable. Removing server savefile. Please restart now."+    (False, RespUpdAtomicUI UpdRestart{}) -> do+      msgAdd $ "Welcome to" <+> title <> "!"+      handleResponseUI cmd1+    _ -> assert `failure` "unexpected command" `twith` (side, restored, cmd1)+  fact <- getsState $ (EM.! side) . sfactionD+  when (playerAI $ gplayer fact) $+    -- Prod the frontend to flush frames and start showing then continuously.+    void $ displayMore ColorFull "The team is under AI control (ESC to stop)."+  -- State and client state now valid.+  debugPrint $ "UI client" <+> tshow side <+> "started."+  loop+  debugPrint $ "UI client" <+> tshow side <+> "stopped."+ where+  loop = do+    cmd <- receiveResponse+    handleResponseUI cmd+    quit <- getsClient squit+    unless quit loop
+ Game/LambdaHack/Client/MonadClient.hs view
@@ -0,0 +1,95 @@+-- | Basic client monad and related operations.+module Game.LambdaHack.Client.MonadClient+  ( -- * Basic client monad+    MonadClient( getClient, getsClient, modifyClient, putClient+               , saveChanClient  -- exposed only to be implemented, not used+               , liftIO  -- exposed only to be implemented, not used+               )+    -- * Assorted primitives+  , debugPrint, saveClient, saveName, restoreGame, removeServerSave, rndToAction+  ) where++import Control.Monad+import qualified Control.Monad.State as St+import Data.Maybe+import Data.Text (Text)+import System.Directory+import System.FilePath++import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.File+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Random+import qualified Game.LambdaHack.Common.Save as Save+import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.RuleKind++class MonadStateRead m => MonadClient m where+  getClient      :: m StateClient+  getsClient     :: (StateClient -> a) -> m a+  modifyClient   :: (StateClient -> StateClient) -> m ()+  putClient      :: StateClient -> m ()+  -- We do not provide a MonadIO instance, so that outside of Action/+  -- nobody can subvert the action monads by invoking arbitrary IO.+  liftIO         :: IO a -> m a+  saveChanClient :: m (Save.ChanSave (State, StateClient))++debugPrint :: MonadClient m => Text -> m ()+debugPrint t = do+  sdbgMsgCli <- getsClient $ sdbgMsgCli . sdebugCli+  when sdbgMsgCli $ liftIO $ Save.delayPrint t++saveClient :: MonadClient m => m ()+saveClient = do+  s <- getState+  cli <- getClient+  toSave <- saveChanClient+  liftIO $ Save.saveToChan toSave (s, cli)++saveName :: FactionId -> Bool -> String+saveName side isAI =+  let n = fromEnum side  -- we depend on the numbering hack to number saves+  in (if n > 0+      then "human_" ++ show n+      else "computer_" ++ show (-n))+     ++ if isAI then ".ai.sav" else ".ui.sav"++restoreGame :: MonadClient m => m (Maybe (State, StateClient))+restoreGame = do+  Kind.COps{corule} <- getsState scops+  let stdRuleset = Kind.stdRuleset corule+      pathsDataFile = rpathsDataFile stdRuleset+      cfgUIName = rcfgUIName stdRuleset+  side <- getsClient sside+  isAI <- getsClient sisAI+  prefix <- getsClient $ ssavePrefixCli . sdebugCli+  let copies = [( "GameDefinition" </> cfgUIName <.> "default"+                , cfgUIName <.> "ini" )]+      name = fromMaybe "save" prefix <.> saveName side isAI+  liftIO $ Save.restoreGame name copies pathsDataFile++-- | Assuming the client runs on the same machine and for the same+-- user as the server, move the server savegame out of the way.+removeServerSave :: MonadClient m => m ()+removeServerSave = do+  -- Hack: assume the same prefix for client as for the server.+  prefix <- getsClient $ ssavePrefixCli . sdebugCli+  dataDir <- liftIO appDataDir+  let serverSaveFile = dataDir+                       </> "saves"+                       </> fromMaybe "save" prefix+                       <.> serverSaveName+  bSer <- liftIO $ doesFileExist serverSaveFile+  when bSer $ liftIO $ renameFile serverSaveFile (serverSaveFile <.> "bkp")++-- | Invoke pseudo-random computation with the generator kept in the state.+rndToAction :: MonadClient m => Rnd a -> m a+rndToAction r = do+  g <- getsClient srandom+  let (a, ng) = St.runState r g+  modifyClient $ \cli -> cli {srandom = ng}+  return a
+ Game/LambdaHack/Client/ProtocolClient.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE FlexibleContexts, FunctionalDependencies, RankNTypes, TupleSections+             #-}+-- | The client-server communication monads.+module Game.LambdaHack.Client.ProtocolClient+  ( MonadClientReadResponse(..), MonadClientWriteRequest(..)+  ) where++import Game.LambdaHack.Client.MonadClient++class MonadClient m => MonadClientReadResponse resp m | m -> resp where+  receiveResponse  :: m resp++class MonadClient m => MonadClientWriteRequest req m | m -> req where+  sendRequest  :: req -> m ()
− Game/LambdaHack/Client/RunAction.hs 
@@ -1,276 +0,0 @@-{-# LANGUAGE RankNTypes #-}--- | Running and disturbance.------ The general rule is: whatever is behind you (and so ignored previously),--- determines what you ignore moving forward. This is calcaulated--- separately for the tiles to the left, to the right and in the middle--- along the running direction. So, if you want to ignore something--- start running when you stand on it (or to the right or left, respectively)--- or by entering it (or passing to the right or left, respectively).------ Some things are never ignored, such as: enemies seen, imporant messages--- heard, solid tiles and actors in the way.-module Game.LambdaHack.Client.RunAction-  ( continueRun, moveRunAid-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.ByteString.Char8 as BS-import qualified Data.EnumMap.Strict as EM-import Data.Function-import Data.List-import Data.Maybe--import Game.LambdaHack.Client.Action-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.ServerCmd-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.TileKind---- | Continue running in the given direction.-continueRun :: MonadClient m-            => RunParams -> m (Either Msg (RunParams, CmdTakeTimeSer))-continueRun paramOld =-  case paramOld of-    RunParams{ runMembers = []-             , runStopMsg = Just stopMsg } -> return $ Left stopMsg-    RunParams{ runLeader-             , runMembers = r : rs-             , runDist = 0-             , runStopMsg-             , runInitDir = Just dir } ->-      if r == runLeader then do-        -- Start a many-actor run with distance 1, to prevent changing-        -- direction on first turn, if the original direction is blocked.-        -- We want our runners to keep formation.-        let runDistNew = if null rs then 0 else 1-        continueRun paramOld{runDist = runDistNew, runInitDir = Nothing}-      else do-        runOutcome <- continueRunDir r 0 (Just dir)-        case runOutcome of-          Left "" -> do  -- hack; means that zeroth step OK-            runStopOrCmd <- moveRunAid r dir-            let runMembersNew = if isJust runStopMsg then rs else rs ++ [r]-                paramNew = paramOld {runMembers = runMembersNew}-            return $! case runStopOrCmd of-              Left stopMsg -> assert `failure` (paramOld, stopMsg)-              Right runCmd -> Right (paramNew, runCmd)-          Left runStopMsgCurrent -> do-            let runStopMsgNew = fromMaybe runStopMsgCurrent runStopMsg-                paramNew = paramOld { runMembers = rs-                                    , runStopMsg = Just runStopMsgNew }-            continueRun paramNew-          _ -> assert `failure` (paramOld, runOutcome)-    RunParams{ runLeader-             , runMembers = r : rs-             , runDist-             , runStopMsg-             , runInitDir = Nothing } -> do-      let runDistNew = if r == runLeader then runDist + 1 else runDist-      mdirOrRunStopMsgCurrent <- continueRunDir r runDistNew Nothing-      let runStopMsgCurrent =-            either Just (const Nothing) mdirOrRunStopMsgCurrent-          runStopMsgNew = runStopMsg `mplus` runStopMsgCurrent-          -- We check @runStopMsgNew@, because even if the current actor-          -- runs OK, we want to stop soon if some others had to stop.-          runMembersNew = if isJust runStopMsgNew then rs else rs ++ [r]-          paramNew = paramOld { runMembers = runMembersNew-                              , runDist = runDistNew-                              , runStopMsg = runStopMsgNew }-      case mdirOrRunStopMsgCurrent of-        Left _ -> continueRun paramNew  -- run all undisturbed; only one time-        Right dir -> return $ Right (paramNew, MoveSer r dir)-      -- The potential invisible actor is hit. War is started without asking.-    _ -> assert `failure` paramOld---- | Actor moves or searches or alters. No visible actor at the position.-moveRunAid :: MonadClient m-           => ActorId -> Vector -> m (Either Msg CmdTakeTimeSer)-moveRunAid source dir = do-  cops@Kind.COps{cotile} <- getsState scops-  sb <- getsState $ getActorBody source-  let lid = blid sb-  lvl <- getLevel lid-  let spos = bpos sb           -- source position-      tpos = spos `shift` dir  -- target position-      t = lvl `at` tpos-      runStopOrCmd =-        -- Movement requires full access.-        if accessible cops lvl spos tpos then-          -- The potential invisible actor is hit. War started without asking.-          Right $ MoveSer source dir-        -- No access, so search and/or alter the tile. Non-walkability is-        -- not implied by the lack of access.-        else if not (Tile.isWalkable cotile t)-                && (isSecretPos lvl tpos  -- possible secrets here-                    && (Tile.isSuspect cotile t  -- not yet searched-                        || hideTile cotile lvl tpos /= t)  -- searching again-                    || Tile.isOpenable cotile t-                    || Tile.isClosable cotile t-                    || Tile.isChangeable cotile t) then-          if not $ EM.null $ lvl `atI` tpos then-            Left $ showFailureSer AlterBlockItem-          else-            Right $ AlterSer source tpos Nothing-            -- We don't use MoveSer, because we don't hit invisible actors.-            -- The potential invisible actor, e.g., in a wall or in-            -- an inaccessible doorway, is made known, taking a turn.-            -- If server performed an attack for free-            -- on the invisible actor anyway, the player (or AI)-            -- would be tempted to repeatedly hit random walls-            -- in hopes of killing a monster lurking within.-            -- If the action had a cost, misclicks would incur the cost, too.-            -- Right now the player may repeatedly alter tiles trying to learn-            -- about invisible pass-wall actors, but it costs a turn-            -- and does not harm the invisible actors, so it's not tempting.-       -- Ignore a known boring, not accessible tile.-       else Left "never mind"-  return $! runStopOrCmd---- | This function implements the actual logic of running. It checks if we--- have to stop running because something interesting cropped up,--- it ajusts the direction given by the vector if we reached--- a corridor's corner (we never change direction except in corridors)--- and it increments the counter of traversed tiles.-continueRunDir :: MonadClient m-               => ActorId -> Int -> Maybe Vector -> m (Either Msg Vector)-continueRunDir aid distLast mdir = do-  sreport <- getsClient sreport -- TODO: check the message before it goes into history-  let boringMsgs = map BS.pack [ "You hear some noises."-                               , "reveals that the" ]-      boring repLine = any (`BS.isInfixOf` repLine) boringMsgs-      -- TODO: use a regexp from the UI config instead-      msgShown  = isJust $ findInReport (not . boring) sreport-  if msgShown then return $ Left "message shown"-  else do-    let maxDistance = 20-    cops@Kind.COps{cotile} <- getsState scops-    body <- getsState $ getActorBody aid-    let lid = blid body-    lvl <- getLevel lid-    let posHere = bpos body-        posLast = boldpos body-        dirLast = displacement posLast posHere-        dir = fromMaybe dirLast mdir-        posThere = posHere `shift` dir-    actorsThere <- getsState $ posToActors posThere lid-    let openableLast = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))-        check-          | not $ null actorsThere = return $ Left "actor in the way"-                         -- don't displace actors, except with leader in step 1-          | distLast >= maxDistance =-              return $ Left $ "reached max run distance" <+> tshow maxDistance-          | accessibleDir cops lvl posHere dir =-              if distLast == 0-              then return $ Left ""  -- hack; means that zeroth step OK-              else checkAndRun aid dir-          | distLast /= 1 = return $ Left "blocked"-                            -- don't change direction, except in step 1-          | openableLast = return $ Left "blocked by a closed door"-                           -- the player may prefer to open the door-          | otherwise =-              -- Assume turning is permitted, because this is the start-              -- of the run, so the situation is mostly known to the player-              tryTurning aid-    check--tryTurning :: MonadClient m-           => ActorId -> m (Either Msg Vector)-tryTurning aid = do-  cops@Kind.COps{cotile} <- getsState scops-  body <- getsState $ getActorBody aid-  let lid = blid body-  lvl <- getLevel lid-  let posHere = bpos body-      posLast = boldpos body-      dirLast = displacement posLast posHere-  let openableDir dir = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))-      dirEnterable dir = accessibleDir cops lvl posHere dir || openableDir dir-      dirNearby dir1 dir2 = euclidDistSqVector dir1 dir2 `elem` [1, 2]-      dirSimilar dir = dirNearby dirLast dir && dirEnterable dir-      dirsSimilar = filter dirSimilar moves-  case dirsSimilar of-    [] -> return $ Left "dead end"-    d1 : ds | all (dirNearby d1) ds ->  -- only one or two directions possible-      case sortBy (compare `on` euclidDistSqVector dirLast)-           $ filter (accessibleDir cops lvl posHere) $ d1 : ds of-        [] ->-          return $ Left "blocked and all similar directions are closed doors"-        d : _ -> checkAndRun aid d-    _ -> return $ Left "blocked and many distant similar directions found"---- The direction is different than the original, if called from @tryTurning@--- and the same if from @continueRunDir@.-checkAndRun :: MonadClient m-            => ActorId -> Vector -> m (Either Msg Vector)-checkAndRun aid dir = do-  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops-  body <- getsState $ getActorBody aid-  smarkSuspect <- getsClient smarkSuspect-  let lid = blid body-  lvl <- getLevel lid-  let posHere = bpos body-      posHasItems pos = not $ EM.null $ lvl `atI` pos-      posThere = posHere `shift` dir-  actorsThere <- getsState $ posToActors posThere lid-  let posLast = boldpos body-      dirLast = displacement posLast posHere-      -- This is supposed to work on unit vectors --- diagonal, as well as,-      -- vertical and horizontal.-      anglePos :: Point -> Vector -> RadianAngle -> Point-      anglePos pos d angle = shift pos (rotate angle d)-      -- We assume the tiles have not changes since last running step.-      -- If they did, we don't care --- running should be stopped-      -- because of the change of nearby tiles then (TODO).-      -- We don't take into account the two tiles at the rear of last-      -- surroundings, because the actor may have come from there-      -- (via a diagonal move) and if so, he may be interested in such tiles.-      -- If he arrived directly from the right or left, he is responsible-      -- for starting the run further away, if he does not want to ignore-      -- such tiles as the ones he came from.-      tileLast = lvl `at` posLast-      tileHere = lvl `at` posHere-      tileThere = lvl `at` posThere-      leftPsLast = map (anglePos posHere dirLast) [pi/2, 3*pi/4]-                   ++ map (anglePos posHere dir) [pi/2, 3*pi/4]-      rightPsLast = map (anglePos posHere dirLast) [-pi/2, -3*pi/4]-                    ++ map (anglePos posHere dir) [-pi/2, -3*pi/4]-      leftForwardPosHere = anglePos posHere dir (pi/4)-      rightForwardPosHere = anglePos posHere dir (-pi/4)-      leftTilesLast = map (lvl `at`) leftPsLast-      rightTilesLast = map (lvl `at`) rightPsLast-      leftForwardTileHere = lvl `at` leftForwardPosHere-      rightForwardTileHere = lvl `at` rightForwardPosHere-      featAt = actionFeatures smarkSuspect . okind-      terrainChangeMiddle = null (Tile.causeEffects cotile tileThere)-                              -- step into; will stop next turn due to message-                            && featAt tileThere-                               `notElem` map featAt [tileLast, tileHere]-      terrainChangeLeft = featAt leftForwardTileHere-                          `notElem` map featAt leftTilesLast-      terrainChangeRight = featAt rightForwardTileHere-                           `notElem` map featAt rightTilesLast-      itemChangeLeft = posHasItems leftForwardPosHere-                       `notElem` map posHasItems leftPsLast-      itemChangeRight = posHasItems rightForwardPosHere-                        `notElem` map posHasItems rightPsLast-      check-        | not $ null actorsThere = return $ Left "actor in the way"-                       -- Actor in possibly another direction tnat original.-        | terrainChangeLeft = return $ Left "terrain change on the left"-        | terrainChangeRight = return $ Left "terrain change on the right"-        | itemChangeLeft = return $ Left "item change on the left"-        | itemChangeRight = return $ Left "item change on the right"-        | terrainChangeMiddle = return $ Left "terrain change in the middle"-        | otherwise = return $ Right dir-  check
Game/LambdaHack/Client/State.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Server and client game state types and operations. module Game.LambdaHack.Client.State-  ( StateClient(..), defStateClient, defHistory+  ( StateClient(..), defStateClient, defaultHistory   , updateTarget, getTarget, updateLeader, sside   , PathEtc, TgtMode(..), Target(..), RunParams(..), LastRecord   , toggleMarkVision, toggleMarkSmell, toggleMarkSuspect@@ -12,27 +12,29 @@ 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 import qualified System.Random as R import System.Time -import Game.LambdaHack.Client.Config+import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.Bfs+import Game.LambdaHack.Client.ItemSlot+import qualified Game.LambdaHack.Client.Key as K import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Animation-import Game.LambdaHack.Common.AtomicCmd+import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.ServerCmd import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector  -- | Client state, belonging to a single faction.@@ -40,9 +42,10 @@ -- from game to game, even across playing sessions. -- Data invariant: if @_sleader@ is @Nothing@ then so is @srunning@. data StateClient = StateClient-  { stgtMode     :: !(Maybe TgtMode)  -- ^ targeting mode-  , scursor      :: !Target           -- ^ the common, cursor target-  , seps         :: !Int              -- ^ a parameter of the tgt digital line+  { stgtMode     :: !(Maybe TgtMode)+                                   -- ^ targeting mode+  , scursor      :: !Target        -- ^ the common, cursor target+  , seps         :: !Int           -- ^ a parameter of the tgt digital line   , stargetD     :: !(EM.EnumMap ActorId (Target, Maybe PathEtc))                                    -- ^ targets of our actors in the dungeon   , sexplored    :: !(ES.EnumSet LevelId)@@ -58,16 +61,15 @@                                    -- ^ parameters of the current run, if any   , sreport      :: !Report        -- ^ current messages   , shistory     :: !History       -- ^ history of messages-  , sundo        :: ![Atomic]      -- ^ atomic commands performed to date+  , sdisplayed   :: !(EM.EnumMap LevelId Time)+                                   -- ^ moves are displayed up to this time+  , sundo        :: ![CmdAtomic]   -- ^ atomic commands performed to date   , sdisco       :: !Discovery     -- ^ remembered item discoveries+  , sdiscoAE     :: !DiscoAE       -- ^ remembered aspects and effects of items   , sfper        :: !FactionPers   -- ^ faction perception indexed by levels   , srandom      :: !R.StdGen      -- ^ current random generator-  , sconfigUI    :: ConfigUI       -- ^ client config (including initial RNG)-  , slastKey     :: !(Maybe K.KM)  -- ^ last command key pressed   , slastRecord  :: !LastRecord    -- ^ state of key sequence recording   , slastPlay    :: ![K.KM]        -- ^ state of key sequence playback-  , slastCmd     :: !(Maybe CmdTakeTimeSer)-                                   -- ^ last command sent to the server   , swaitTimes   :: !Int           -- ^ player just waited this many times   , _sleader     :: !(Maybe ActorId)                                    -- ^ current picked party leader@@ -78,6 +80,9 @@   , smarkSmell   :: !Bool          -- ^ mark smell, if the leader can smell   , smarkSuspect :: !Bool          -- ^ mark suspect features   , scurDifficulty :: !Int         -- ^ current game difficulty level+  , sslots       :: !ItemSlots     -- ^ map from slots to items+  , slastSlot    :: !SlotChar      -- ^ last used slot+  , sgameMode    :: !Text          -- ^ current game mode   , sdebugCli    :: !DebugModeCli  -- ^ client debugging mode   }   deriving Show@@ -115,45 +120,46 @@                   )  -- | Initial game client state.-defStateClient :: History -> ConfigUI -> FactionId -> Bool-               -> StateClient-defStateClient shistory sconfigUI _sside sisAI =+defStateClient :: History -> Report -> FactionId -> Bool -> StateClient+defStateClient shistory sreport _sside sisAI =   StateClient     { stgtMode = Nothing     , scursor = if sisAI                 then TVector $ Vector 30000 30000  -- invalid                 else TVector $ Vector 1 1  -- a step south-east-    , seps = 0+    , seps = fromEnum _sside     , stargetD = EM.empty     , sexplored = ES.empty     , sbfsD = EM.empty     , sselected = ES.empty     , srunning = Nothing-    , sreport = emptyReport+    , sreport     , shistory+    , sdisplayed = EM.empty     , sundo = []     , sdisco = EM.empty+    , sdiscoAE = EM.empty     , sfper = EM.empty-    , sconfigUI     , srandom = R.mkStdGen 42  -- will be set later-    , slastKey = Nothing     , slastRecord = ([], [], 0)     , slastPlay = []-    , slastCmd = Nothing     , swaitTimes = 0     , _sleader = Nothing  -- no heroes yet alive     , _sside     , squit = False     , sisAI     , smarkVision = False-    , smarkSmell = False+    , smarkSmell = True     , smarkSuspect = False-    , scurDifficulty = 0+    , scurDifficulty = difficultyDefault+    , sslots = (EM.empty, IM.empty)+    , slastSlot = SlotChar 'a'+    , sgameMode = "campaign"     , sdebugCli = defDebugModeCli     } -defHistory :: IO History-defHistory = do+defaultHistory :: IO History+defaultHistory = do   dateTime <- getClockTime   let curDate = MU.Text $ T.pack $ calendarTimeToString $ toUTCTime dateTime   return $! singletonHistory $ singletonReport@@ -206,7 +212,9 @@     put sreport     put shistory     put sundo+    put sdisplayed     put sdisco+    put sdiscoAE     put (show srandom)     put _sleader     put _sside@@ -215,6 +223,9 @@     put smarkSmell     put smarkSuspect     put scurDifficulty+    put sslots+    put slastSlot+    put sgameMode     put sdebugCli  -- TODO: this is overwritten at once   get = do     stgtMode <- get@@ -227,7 +238,9 @@     sreport <- get     shistory <- get     sundo <- get+    sdisplayed <- get     sdisco <- get+    sdiscoAE <- get     g <- get     _sleader <- get     _sside <- get@@ -236,17 +249,17 @@     smarkSmell <- get     smarkSuspect <- get     scurDifficulty <- get+    sslots <- get+    slastSlot <- get+    sgameMode <- get     sdebugCli <- get     let sbfsD = EM.empty         sfper = EM.empty         srandom = read g-        slastKey = Nothing         slastRecord = ([], [], 0)         slastPlay = []-        slastCmd = Nothing         swaitTimes = 0         squit = False-        sconfigUI = undefined     return $! StateClient{..}  instance Binary RunParams where
− Game/LambdaHack/Client/Strategy.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE DeriveFoldable, DeriveTraversable #-}--- | 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.Strategy-  ( Strategy, nullStrategy, liftFrequency-  , (.|), reject, (.=>), only, bestVariant, renameStrategy, returN-  ) where--import Control.Applicative-import Control.Monad-import Data.Foldable (Foldable)-import Data.Text (Text)-import Data.Traversable (Traversable)--import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Utils.Frequency as Frequency---- | A strategy is a choice of (non-empty) frequency tables--- of possible actions.-newtype Strategy a = Strategy { runStrategy :: [Frequency a] }-  deriving (Show, Foldable, Traversable)---- | Strategy is a monad. TODO: Can we write this as a monad transformer?-instance Monad Strategy where-  {-# INLINE return #-}-  return x = Strategy $ return $! uniformFreq "Strategy_return" [x]-  m >>= f  = normalizeStrategy $ Strategy-    [ toFreq name [ (p * q, b)-                  | (p, a) <- runFrequency x-                  , y <- runStrategy (f a)-                  , (q, b) <- runFrequency y-                  ]-    | x <- runStrategy m-    , let name = "Strategy_bind (" <> nameFrequency x <> ")"]--instance Functor Strategy where-  fmap f (Strategy fs) = Strategy (map (fmap f) fs)--instance Applicative Strategy where-  pure  = return-  (<*>) = ap--instance MonadPlus Strategy where-  mzero = Strategy []-  {-# INLINE mplus #-}-  mplus (Strategy xs) (Strategy ys) = Strategy (xs ++ ys)--instance Alternative Strategy where-  (<|>) = mplus-  empty = mzero--normalizeStrategy :: Strategy a -> Strategy a-normalizeStrategy (Strategy fs) = Strategy $ filter (not . nullFreq) fs--nullStrategy :: Strategy a -> Bool-nullStrategy strat = null $ runStrategy strat---- | Strategy where only the actions from the given single frequency table--- can be picked.-liftFrequency :: Frequency a -> Strategy a-liftFrequency f = normalizeStrategy $ Strategy $ return f--infixr 2 .|---- | Strategy with the actions from both argument strategies,--- with original frequencies.-(.|) :: Strategy a -> Strategy a -> Strategy a-(.|) = mplus---- | Strategy with no actions at all.-reject :: Strategy a-reject = mzero--infix 3 .=>---- | Conditionally accepted strategy.-(.=>) :: Bool -> Strategy a -> Strategy a-p .=> m | p          =  m-        | otherwise  =  mzero---- | Strategy with all actions not satisfying the predicate removed.--- The remaining actions keep their original relative frequency values.-only :: (a -> Bool) -> Strategy a -> Strategy a-only p s = normalizeStrategy $ do-  x <- s-  p x .=> return x---- | When better choices are towards the start of the list,--- this is the best frequency of the strategy.-bestVariant :: Strategy a -> Frequency a-bestVariant (Strategy []) = mzero-bestVariant (Strategy (f : _)) = f---- | Overwrite the description of all frequencies within the strategy.-renameStrategy :: Text -> Strategy a -> Strategy a-renameStrategy newName (Strategy fs) = Strategy $ map (renameFreq newName) fs---- | Like 'return', but pick a name of the single frequency.-returN :: Text -> a -> Strategy a-returN name x = Strategy $ return $! uniformFreq name [x]
− Game/LambdaHack/Client/StrategyAction.hs 
@@ -1,695 +0,0 @@--- | AI strategy operations implemented with the 'Action' monad.-module Game.LambdaHack.Client.StrategyAction-  ( targetStrategy, actionStrategy-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Function-import Data.List-import Data.Maybe-import Data.Ord-import qualified Data.Traversable as Traversable--import Game.LambdaHack.Client.Action-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.Strategy-import Game.LambdaHack.Common.Ability (Ability)-import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import qualified Game.LambdaHack.Common.Random as Random-import Game.LambdaHack.Common.ServerCmd-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ActorKind-import Game.LambdaHack.Content.FactionKind-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.TileKind as TileKind-import Game.LambdaHack.Utils.Frequency---- | AI proposes possible targets for the actor. Never empty.-targetStrategy :: forall m. MonadClient m-               => ActorId -> ActorId -> m (Strategy (Target, PathEtc))-targetStrategy oldLeader aid = do-  Kind.COps{ cotile=cotile@Kind.Ops{ouniqGroup}-           , coactor=Kind.Ops{okind}-           , cofaction=Kind.Ops{okind=fokind} } <- getsState scops-  modifyClient $ \cli -> cli {sbfsD = EM.delete aid (sbfsD cli)}-  b <- getsState $ getActorBody aid-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  oldTgtUpdatedPath <- case mtgtMPath of-    Just (tgt, Just path) -> do-      mvalidPos <- aidTgtToPos aid (blid b) (Just tgt)-      if isNothing mvalidPos then return Nothing  -- wrong level-      else return $! case path of-        (p : q : rest, (goal, len)) ->-          if bpos b == p-          then Just (tgt, path)  -- no move last turn-          else if bpos b == q-               then Just (tgt, (q : rest, (goal, len - 1)))  -- step along path-               else Nothing  -- veered off the path-        ([p], (goal, _)) -> do-          assert (p == goal `blame` (aid, b, mtgtMPath)) skip-          if bpos b == p then-            Just (tgt, path)  -- goal reached; stay there picking up items-          else-            Nothing  -- somebody pushed us off the goal; let's target again-        ([], _) -> assert `failure` (aid, b, mtgtMPath)-    Just (_, Nothing) -> return Nothing  -- path invalidated, e.g. SpotActorA-    Nothing -> return Nothing  -- no target assigned yet-  lvl <- getLevel $ blid b-  assert (not $ bproj b) skip  -- would work, but is probably a bug-  fact <- getsState $ \s -> sfactionD s EM.! bfid b-  allFoes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid b)-  dungeon <- getsState sdungeon-  -- TODO: we assume the actor eventually becomes a leader (or has the same-  -- set of abilities as the leader, anyway) and set his target accordingly.-  actorAbs <- actorAbilities aid (Just aid)-  let nearby = 10-      nearbyFoes = filter (\(_, body) ->-                             chessDist (bpos body) (bpos b) < nearby) allFoes-      unknownId = ouniqGroup "unknown space"-      -- TODO: make more common when weak ranged foes preferred, etc.-      focused = bspeed b < speedNormal-      canSmell = asmell $ okind $ bkind b-      setPath :: Target -> m (Strategy (Target, PathEtc))-      setPath tgt = do-        mpos <- aidTgtToPos aid (blid b) (Just tgt)-        let p = fromMaybe (assert `failure` (b, tgt)) mpos-        (bfs, mpath) <- getCacheBfsAndPath aid p-        case mpath of-          Nothing -> assert `failure` "new target unreachable" `twith` (b, tgt)-          Just path ->-            return $! returN "pickNewTarget"-              (tgt, ( bpos b : path-                    , (p, fromMaybe (assert `failure` mpath)-                          $ accessBfs bfs p) ))-      pickNewTarget :: m (Strategy (Target, PathEtc))-      pickNewTarget = do-        -- TODO: for foes, items, etc. consider a few nearby, not just one-        cfoes <- closestFoes aid-        case cfoes of-          (_, (a, _)) : _ -> setPath $ TEnemy a False-          [] -> do-            -- Tracking enemies is more important than exploring,-            -- and smelling actors are usually blind, so bad at exploring.-            -- TODO: prefer closer items to older smells-            smpos <- if canSmell-                     then closestSmell aid-                     else return []-            case smpos of-              [] -> do-                citems <- if Ability.Pickup `elem` actorAbs-                          then closestItems aid-                          else return []-                case citems of-                  [] -> do-                    upos <- closestUnknown aid-                    case upos of-                      Nothing -> do-                        ctriggers <- if Ability.Trigger `elem` actorAbs-                                     then closestTriggers Nothing False aid-                                     else return []-                        case ctriggers of-                          [] -> do-                            getDistant <--                              rndToAction $ oneOf-                              $ [fmap maybeToList . furthestKnown]-                                ++ [ closestTriggers Nothing True-                                   | EM.size dungeon > 1 ]-                            kpos <- getDistant aid-                            case kpos of-                              [] -> return reject-                              p : _ -> setPath $ TPoint (blid b) p-                          p : _ -> setPath $ TPoint (blid b) p-                      Just p -> setPath $ TPoint (blid b) p-                  (_, (p, _)) : _ -> setPath $ TPoint (blid b) p-              (_, (p, _)) : _ -> setPath $ TPoint (blid b) p-      tellOthersNothingHere pos = do-        let f (tgt, _) = case tgt of-              TEnemyPos _ lid p _ -> p /= pos || lid /= blid b-              _ -> True-        modifyClient $ \cli -> cli {stargetD = EM.filter f (stargetD cli)}-        pickNewTarget-      updateTgt :: Target -> PathEtc-                -> m (Strategy (Target, PathEtc))-      updateTgt oldTgt updatedPath = case oldTgt of-        TEnemy a _ -> do-          body <- getsState $ getActorBody a-          if not focused  -- prefers closer foes-             && not (null nearbyFoes)  -- foes nearby-             && a `notElem` map fst nearbyFoes  -- old one not close enough-             || blid body /= blid b  -- wrong level-          then pickNewTarget-          else if bpos body == fst (snd updatedPath)-               then return $! returN "TEnemy" (oldTgt, updatedPath)-                      -- The enemy didn't move since the target acquired.-                      -- If any walls were added that make the enemy-                      -- unreachable, AI learns that the hard way,-                      -- as soon as it bumps into them.-               else do-                 let p = bpos body-                 (bfs, mpath) <- getCacheBfsAndPath aid p-                 case mpath of-                   Nothing -> pickNewTarget  -- enemy became unreachable-                   Just path ->-                      return $! returN "TEnemy"-                        (oldTgt, ( bpos b : path-                                 , (p, fromMaybe (assert `failure` mpath)-                                       $ accessBfs bfs p) ))-        _ | not $ null nearbyFoes ->-          pickNewTarget  -- prefer close foes to anything-        TPoint lid pos -> do-          explored <- getsClient sexplored-          let allExplored = ES.size explored == EM.size dungeon-              abilityLeader = fAbilityLeader $ fokind $ gkind fact-              abilityOther = fAbilityOther $ fokind $ gkind fact-          if lid /= blid b  -- wrong level-             -- Below we check the target could not be picked again in-             -- pickNewTarget, and only in this case it is invalidated.-             -- This ensures targets are eventually reached (unless a foe-             -- shows up) and not changed all the time mid-route-             -- to equally interesting, but perhaps a bit closer targets,-             -- most probably already targeted by other actors.-             || (Ability.Pickup `notElem` actorAbs  -- closestItems-                 || EM.null (lvl `atI` pos))-                && (not canSmell  -- closestSmell-                    || pos == bpos b  -- in case server resends deleted smell-                    || let sml =-                             EM.findWithDefault timeZero pos (lsmell lvl)-                       in sml `timeAdd` timeNegate (ltime lvl) <= timeZero)-                && let t = lvl `at` pos-                   in if ES.notMember lid explored-                      then  -- closestUnknown-                        t /= unknownId-                        && not (Tile.isSuspect cotile t)-                      else  -- closestTriggers-                        -- Try to kill that very last enemy for his loot before-                        -- leaving the level or dungeon.-                        not (null allFoes)-                        || -- If all explored, escape/block escapes.-                           (Ability.Trigger `notElem` actorAbs-                            || not (Tile.isEscape cotile t && allExplored))-                           -- The next case is stairs in closestTriggers.-                           -- We don't determine if the stairs are interesting-                           -- (this changes with time), but allow the actor-                           -- to reach them and then retarget.-                           && not (pos /= bpos b && Tile.isStair cotile t)-                           -- The remaining case is furthestKnown. This is-                           -- always an unimportant target, so we forget it-                           -- if the actor is stuck (could move, but waits).-                           && let isStuck =-                                    waitedLastTurn b-                                    && (oldLeader == aid-                                        || abilityLeader == abilityOther)-                              in not (pos /= bpos b-                                      && not isStuck-                                      && allExplored)-          then pickNewTarget-          else return $! returN "TPoint" (oldTgt, updatedPath)-        _ | not $ null allFoes ->-          pickNewTarget  -- new likely foes location spotted, forget the old-        TEnemyPos _ lid p _ ->-          -- Chase last position even if foe hides or dies,-          -- to find his companions, loot, etc.-          if lid /= blid b  -- wrong level-          then pickNewTarget-          else if p == bpos b-               then tellOthersNothingHere p-               else return $! returN "TEnemyPos" (oldTgt, updatedPath)-        TVector{} -> pickNewTarget-  case oldTgtUpdatedPath of-    Just (oldTgt, updatedPath) -> updateTgt oldTgt updatedPath-    Nothing -> pickNewTarget---- | AI strategy based on actor's sight, smell, intelligence, etc.--- Never empty.-actionStrategy :: forall m. MonadClient m-               => ActorId -> m (Strategy CmdTakeTimeSer)-actionStrategy aid = do-  cops <- getsState scops-  disco <- getsClient sdisco-  btarget <- getsClient $ getTarget aid-  Actor{bpos, blid} <- getsState $ getActorBody aid-  bitems <- getsState $ getActorItem aid-  lootItems <- getsState $ getFloorItem blid bpos-  lvl <- getLevel blid-  mleader <- getsClient _sleader-  actorAbs <- actorAbilities aid mleader-  let mfAid =-        case btarget of-          Just (TEnemy foeAid _) -> Just foeAid-          _ -> Nothing-      foeVisible = isJust mfAid-      lootHere x = not $ EM.null $ lvl `atI` x-      lootIsWeapon = isJust $ strongestSword cops lootItems-      hasNoWeapon = isNothing $ strongestSword cops bitems-      isDistant = (`elem` [ Ability.Trigger-                          , Ability.Ranged-                          , Ability.Tools-                          , Ability.Chase ])-      -- TODO: this is too fragile --- depends on order of abilities-      (prefix, rest)    = break isDistant actorAbs-      (distant, suffix) = partition isDistant rest-      aFrequency :: Ability -> m (Frequency CmdTakeTimeSer)-      aFrequency Ability.Trigger = if foeVisible then return mzero-                                   else triggerFreq aid-      aFrequency Ability.Ranged  = rangedFreq aid-      aFrequency Ability.Tools   = if not foeVisible then return mzero-                                   else toolsFreq disco aid-      aFrequency Ability.Chase   = if not foeVisible then return mzero-                                   else chaseFreq-      aFrequency ab              = assert `failure` "unexpected ability"-                                          `twith` (ab, distant, actorAbs)-      chaseFreq :: MonadActionRO m => m (Frequency CmdTakeTimeSer)-      chaseFreq = do-        st <- chase aid True-        return $! scaleFreq 30 $ bestVariant st-      aStrategy :: Ability -> m (Strategy CmdTakeTimeSer)-      aStrategy Ability.Track  = track aid-      aStrategy Ability.Heal   = return reject  -- TODO-      aStrategy Ability.Flee   = return reject  -- TODO-      aStrategy Ability.Melee | foeVisible = melee aid-      aStrategy Ability.Melee  = return reject-      aStrategy Ability.Displace = displace aid-      aStrategy Ability.Pickup | not foeVisible && lootHere bpos-                                 || hasNoWeapon && lootIsWeapon = pickup aid-      aStrategy Ability.Pickup = return reject-      aStrategy Ability.Wander = chase aid False-      aStrategy ab             = assert `failure` "unexpected ability"-                                        `twith`(ab, actorAbs)-      sumS abis = do-        fs <- mapM aStrategy abis-        return $! msum fs-      sumF abis = do-        fs <- mapM aFrequency abis-        return $! msum fs-      combineDistant as = fmap liftFrequency $ sumF as-  sumPrefix <- sumS prefix-  comDistant <- combineDistant distant-  sumSuffix <- sumS suffix-  return $! sumPrefix .| comDistant .| sumSuffix-            -- Wait until friends sidestep; ensures strategy is never empty.-            -- TODO: try to switch leader away before that (we already-            -- switch him afterwards)-            .| waitBlockNow aid---- | A strategy to always just wait.-waitBlockNow :: ActorId -> Strategy CmdTakeTimeSer-waitBlockNow aid = returN "wait" $ WaitSer aid---- | Strategy for a dumb missile or a strongly hurled actor.-track :: MonadActionRO m => ActorId -> m (Strategy CmdTakeTimeSer)-track aid = do-  btrajectory <- getsState $ btrajectory . getActorBody aid-  return $! if isNothing btrajectory-            then reject-            else returN "SetTrajectorySer" $ SetTrajectorySer aid---- TODO: (most?) animals don't pick up. Everybody else does.--- TODO: pick up best weapons first-pickup :: MonadActionRO m => ActorId -> m (Strategy CmdTakeTimeSer)-pickup aid = do-  body@Actor{bpos, blid} <- getsState $ getActorBody aid-  lvl <- getLevel blid-  actionPickup <- case EM.minViewWithKey $ lvl `atI` bpos of-    Nothing -> assert `failure` "pickup of empty pile" `twith` (aid, bpos, lvl)-    Just ((iid, k), _) -> do  -- pick up first item-      item <- getsState $ getItemBody iid-      let l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing-      return $! case assignLetter iid l body of-        Just _ -> returN "pickup" $ PickupSer aid iid k-        Nothing -> returN "pickup" $ WaitSer aid  -- TODO-  return $! actionPickup---- Everybody melees in a pinch, even though some prefer ranged attacks.-melee :: MonadClient m => ActorId -> m (Strategy CmdTakeTimeSer)-melee aid = do-  b <- getsState $ getActorBody aid-  fact <- getsState $ \s -> sfactionD s EM.! bfid b-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  str1 <- case mtgtMPath of-    Just (_, Just (_ : q : _, (goal, _))) -> do-      -- We prefer the goal (e.g., when no accessible, but adjacent),-      -- but accept @q@ even if it's only a blocking enemy position.-      let maim = if adjacent (bpos b) goal then Just goal-                 else if adjacent (bpos b) q then Just q-                 else Nothing  -- MeleeDistant-      mBlocker <- case maim of-        Nothing -> return Nothing-        Just aim -> getsState $ posToActor aim (blid b)-      case mBlocker of-        Just ((aid2, _), _) -> do-          -- No problem if there are many projectiles at the spot. We just-          -- attack the first one.-          body2 <- getsState $ getActorBody aid2-          if isAtWar fact (bfid body2) then-            return $! returN "melee in the way" (MeleeSer aid aid2)-          else return reject-        Nothing -> return reject-    _ -> return reject  -- probably no path to the foe, if any-  -- TODO: depending on actor kind, sometimes move this in strategy-  -- to a place after movement-  if not $ nullStrategy str1 then return str1 else do-    Level{lxsize, lysize} <- getLevel $ blid b-    allFoes <- getsState $ actorNotProjAssocs (isAtWar fact) (blid b)-    let vic = vicinity lxsize lysize $ bpos b-        adjFoes = filter ((`elem` vic) . bpos . snd) allFoes-        -- TODO: prioritize somehow-        freq = uniformFreq "melee adjacent" $ map (MeleeSer aid . fst) adjFoes-    return $ liftFrequency freq---- Fast monsters don't pay enough attention to features.-triggerFreq :: MonadClient m => ActorId -> m (Frequency CmdTakeTimeSer)-triggerFreq aid = do-  cops@Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops-  dungeon <- getsState sdungeon-  explored <- getsClient sexplored-  b <- getsState $ getActorBody aid-  fact <- getsState $ \s -> sfactionD s EM.! bfid b-  lvl <- getLevel $ blid b-  unexploredD <- unexploredDepth-  s <- getState-  let unexploredCurrent = ES.notMember (blid b) explored-      allExplored = ES.size explored == EM.size dungeon-      isHero = isHeroFact cops fact-      t = lvl `at` bpos b-      feats = TileKind.tfeature $ okind t-      ben feat = case feat of-        F.Cause (Effect.Ascend k) ->  -- change levels sensibly, in teams-          let expBenefit =-                if unexploredCurrent-                then 0  -- don't leave the level until explored-                else if unexploredD (signum k) (blid b)-                then 1000-                else if unexploredD (- signum k) (blid b)-                then 0  -- wait for stairs in the opposite direciton-                else if lescape lvl-                then 0  -- all explored, stay on the escape level-                else 2  -- no escape anywhere, switch levels occasionally-              (lid2, pos2) = whereTo (blid b) (bpos b) k dungeon-              actorsThere = posToActors pos2 lid2 s-          in if boldpos b == bpos b   -- probably used stairs last turn-                && boldlid b == lid2  -- in the opposite direction-             then 0  -- avoid trivial loops (pushing, being pushed, etc.)-             else case actorsThere of-               [] -> expBenefit-               [((_, body), _)] | not (bproj body)-                                  && isAtWar fact (bfid body) ->-                 min 1 expBenefit  -- push the enemy if no better option-               _ -> 0  -- projectiles or non-enemies-        F.Cause ef@Effect.Escape{} ->-          -- Only heroes escape but they first explore all for high score.-          if not (isHero && allExplored) then 0 else effectToBenefit cops b ef-        F.Cause ef -> effectToBenefit cops b ef-        _ -> 0-      benFeat = zip (map ben feats) feats-  return $! toFreq "triggerFreq" $ [ (benefit, TriggerSer aid (Just feat))-                                   | (benefit, feat) <- benFeat-                                   , benefit > 0 ]---- Actors require sight to use ranged combat and intelligence to throw--- or zap anything else than obvious physical missiles.-rangedFreq :: MonadClient m-           => ActorId -> m (Frequency CmdTakeTimeSer)-rangedFreq aid = do-  cops@Kind.COps{ coactor=Kind.Ops{okind}-                , coitem=coitem@Kind.Ops{okind=iokind}-                , corule-                } <- getsState scops-  btarget <- getsClient $ getTarget aid-  b@Actor{bkind, bpos, bfid, blid, bbag, binv} <- getsState $ getActorBody aid-  mfpos <- aidTgtToPos aid blid btarget-  case (btarget, mfpos) of-    (Just TEnemy{}, Just fpos) -> do-      disco <- getsClient sdisco-      itemD <- getsState sitemD-      lvl@Level{lxsize, lysize} <- getLevel blid-      let mk = okind bkind-          tis = lvl `atI` bpos-      fact <- getsState $ \s -> sfactionD s EM.! bfid-      foes <- getsState $ actorNotProjList (isAtWar fact) blid-      let foesAdj = foesAdjacent lxsize lysize bpos foes-      (steps, eps) <- makePath b fpos-      let permitted = (if aiq mk >= 10 then ritemProject else ritemRanged)-                      $ Kind.stdRuleset corule-          itemReaches item =-            let lingerPercent = isLingering coitem disco item-                toThrow = maybe 0 (itoThrow . iokind) $ jkind disco item-                speed = speedFromWeight (jweight item) toThrow-                range = rangeFromSpeed speed-                totalRange = lingerPercent * range `div` 100-            in steps <= totalRange  -- probably enough range-                 -- TODO: make sure itoThrow identified after a single throw-          getItemB iid =-            fromMaybe (assert `failure` "item body not found"-                              `twith` (iid, itemD)) $ EM.lookup iid itemD-          throwFreq bag multi container =-            [ (- benefit * multi,-              ProjectSer aid fpos eps iid (container iid))-            | (iid, i) <- map (\iid -> (iid, getItemB iid))-                          $ EM.keys bag-            , let benefit =-                    case jkind disco i of-                      Nothing -> -- TODO: (undefined, 0)  --- for now, cheating-                        effectToBenefit cops b (jeffect i)-                      Just _ki ->-                        let _kik = iokind _ki-                            _unneeded = isymbol _kik-                        in effectToBenefit cops b (jeffect i)-            , benefit < 0-            , jsymbol i `elem` permitted-            , itemReaches i ]-          freq =-            if asight mk  -- ProjectBlind-               && not foesAdj  -- ProjectBlockFoes-               -- ProjectAimOnself, ProjectBlockActor, ProjectBlockTerrain-               -- and no actors or obstracles along the path-               && steps == chessDist bpos fpos-            then toFreq "throwFreq"-                 $ throwFreq bbag 4 (actorContainer aid binv)-                   ++ throwFreq tis 8 (const $ CFloor blid bpos)-            else toFreq "throwFreq: not possible" []-      return $! freq-    _ -> return $! toFreq "throwFreq: no enemy target" []---- TODO: finetune eps--- | Counts the number of steps until the projectile would hit--- an actor or obstacle.-makePath :: MonadClient m => Actor -> Point -> m (Int, Int)-makePath body fpos = do-  cops <- getsState scops-  lvl@Level{lxsize, lysize} <- getLevel (blid body)-  bs <- getsState $ actorNotProjList (const True) (blid body)-  let eps = 0-      mbl = bla lxsize lysize eps (bpos body) fpos-  case mbl of-    Just bl@(pos1:_) -> do-      let noActor p = any ((== p) . bpos) bs-      case break noActor bl of-        (flies, hits : _) -> do-          let blRest = flies ++ [hits]-              blZip = zip (bpos body : blRest) blRest-              blAccess = takeWhile (uncurry $ accessible cops lvl) blZip-          mab <- getsState $ posToActor pos1 (blid body)-          if maybe True (bproj . snd . fst) mab then-            return $ (length blAccess, eps)-          else return (0, eps)  -- ProjectBlockActor-        _ -> assert `failure` (body, fpos, bl)-    Just [] -> assert `failure` (body, fpos)-    Nothing -> return (0, eps)  -- ProjectAimOnself---- Tools use requires significant intelligence and sometimes literacy.-toolsFreq :: MonadActionRO m-          => Discovery -> ActorId -> m (Frequency CmdTakeTimeSer)-toolsFreq disco aid = do-  cops@Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops-  b@Actor{bkind, bpos, blid, bbag, binv} <- getsState $ getActorBody aid-  lvl <- getLevel blid-  s <- getState-  let tis = lvl `atI` bpos-      mk = okind bkind-      mastered | aiq mk < 5 = ""-               | aiq mk < 10 = "!"-               | otherwise = "!?"  -- literacy required-      useFreq bag multi container =-        [ (benefit * multi, ApplySer aid iid (container iid))-        | (iid, i) <- map (\iid -> (iid, getItemBody iid s))-                      $ EM.keys bag-        , let benefit =-                case jkind disco i of-                  Nothing -> 30  -- experimenting is fun-                  Just _ki -> effectToBenefit cops b $ jeffect i-        , benefit > 0-        , jsymbol i `elem` mastered ]-  return $! toFreq "useFreq" $-    useFreq bbag 1 (actorContainer aid binv)-    ++ useFreq tis 2 (const $ CFloor blid bpos)--displace :: MonadClient m => ActorId -> m (Strategy CmdTakeTimeSer)-displace aid = do-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  str <- case mtgtMPath of-    Just (_, Just (p : q : _, _)) -> displaceTowards aid p q-    _ -> return reject  -- goal reached-  Traversable.mapM (moveOrRunAid True aid) str---- TODO: perhaps modify target when actually moving, not when--- producing the strategy, even if it's a unique choice in this case.-displaceTowards :: MonadClient m-                => ActorId -> Point -> Point -> m (Strategy Vector)-displaceTowards aid source target = do-  cops <- getsState scops-  b <- getsState $ getActorBody aid-  assert (source == bpos b && adjacent source target) skip-  lvl <- getsState $ (EM.! blid b) . sdungeon-  if boldpos b /= target -- avoid trivial loops-     && accessible cops lvl source target then do-    mBlocker <- getsState $ posToActors target (blid b)-    case mBlocker of-      [] -> return reject-      [((aid2, _), _)] -> do-        mtgtMPath <- getsClient $ EM.lookup aid2 . stargetD-        case mtgtMPath of-          Just (tgt, Just (p : q : rest, (goal, len)))-            | q == source && p == target -> do-              let newTgt = Just (tgt, Just (q : rest, (goal, len - 1)))-              modifyClient $ \cli ->-                cli {stargetD = EM.alter (const $ newTgt) aid (stargetD cli)}-              return $! returN "displace friend" $ displacement source target-          Just _ -> return reject-          Nothing ->-            return $! returN "displace other" $ displacement source target-      _ -> return reject  -- many projectiles, can't displace-  else return reject--chase :: MonadClient m => ActorId -> Bool -> m (Strategy CmdTakeTimeSer)-chase aid foeVisible = do-  mtgtMPath <- getsClient $ EM.lookup aid . stargetD-  str <- case mtgtMPath of-    Just (_, Just (p : q : _, (goal, _))) -> moveTowards aid p q goal-    _ -> return reject  -- goal reached-  if foeVisible  -- don't pick fights, but displace, if the real foe is close-    then Traversable.mapM (moveOrRunAid True aid) str-    else Traversable.mapM (moveOrRunAid False aid) str--moveTowards :: MonadClient m-            => ActorId -> Point -> Point -> Point -> m (Strategy Vector)-moveTowards aid source target goal = do-  cops@Kind.COps{coactor=Kind.Ops{okind}, cotile} <- getsState scops-  b <- getsState $ getActorBody aid-  assert (source == bpos b && adjacent source target) skip-  lvl <- getsState $ (EM.! blid b) . sdungeon-  fact <- getsState $ (EM.! bfid b) . sfactionD-  friends <- getsState $ actorList (not . isAtWar fact) $ blid b-  let _mk = okind $ bkind b-      noFriends = unoccupied friends-      -- Was:-      -- noFriends | asight mk = unoccupied friends-      --           | otherwise = const True-      -- but this should be implemented on the server or, if not,-      -- restricted to AI-only factions (e.g., animals).-      -- Otherwise human players are tempted to tweak their AI clients-      -- (as soon as we let them register their AI clients with the server).-      accessibleHere = accessible cops lvl source-      bumpableHere p =-        let t = lvl `at` p-        in Tile.isOpenable cotile t || Tile.isSuspect cotile t-      enterableHere p = accessibleHere p || bumpableHere p-  if noFriends target && enterableHere target then-    return $! returN "moveTowards adjacent" $ displacement source target-  else do-    let goesBack v = v == displacement source (boldpos b)-        nonincreasing p = chessDist source goal >= chessDist p goal-        isSensible p = nonincreasing p && noFriends p && enterableHere p-        sensible = [ ((goesBack v, chessDist p goal), v)-                   | v <- moves, let p = source `shift` v, isSensible p ]-        sorted = sortBy (comparing fst) sensible-        groups = map (map snd) $ groupBy ((==) `on` fst) sorted-        freqs = map (liftFrequency . uniformFreq "moveTowards") groups-    return $! foldr (.|) reject freqs---- | Actor moves or searches or alters or attacks. Displaces if @run@.-moveOrRunAid :: MonadActionRO m-             => Bool -> ActorId -> Vector -> m CmdTakeTimeSer-moveOrRunAid run source dir = do-  cops@Kind.COps{cotile} <- getsState scops-  sb <- getsState $ getActorBody source-  let lid = blid sb-  lvl <- getLevel lid-  let spos = bpos sb           -- source position-      tpos = spos `shift` dir  -- target position-      t = lvl `at` tpos-  -- We start by checking actors at the the target position,-  -- which gives a partial information (actors can be invisible),-  -- as opposed to accessibility (and items) which are always accurate-  -- (tiles can't be invisible).-  tgts <- getsState $ posToActors tpos lid-  case tgts of-    [((target, _), _)] | run ->  -- can be a foe, as well as a friend-      if accessible cops lvl spos tpos then-        -- Displacing requires accessibility.-        return $! DisplaceSer source target-      else-        -- If cannot displace, hit. No DisplaceAccess.-        return $! MeleeSer source target-    ((target, _), _) : _ ->  -- can be a foe, as well as a friend (e.g., proj.)-      -- No problem if there are many projectiles at the spot. We just-      -- attack the first one.-      -- Attacking does not require full access, adjacency is enough.-      return $! MeleeSer source target-    [] -> do  -- move or search or alter-      if accessible cops lvl spos tpos then-        -- Movement requires full access.-        return $! MoveSer source dir-        -- The potential invisible actor is hit.-      else if not $ EM.null $ lvl `atI` tpos then-        -- This is, e.g., inaccessible open door with an item in it.-        assert `failure` "AI causes AlterBlockItem" `twith` (run, source, dir)-      else if not (Tile.isWalkable cotile t)  -- not implied-              && (Tile.isSuspect cotile t-                  || Tile.isOpenable cotile t-                  || Tile.isClosable cotile t-                  || Tile.isChangeable cotile t) then-        -- No access, so search and/or alter the tile.-        return $! AlterSer source tpos Nothing-      else-        -- Boring tile, no point bumping into it, do WaitSer if really idle.-        assert `failure` "AI causes MoveNothing or AlterNothing"-               `twith` (run, source, dir)---- | How much AI benefits from applying the effect. Multipllied by item p.--- Negative means harm to the enemy when thrown at him. Effects with zero--- benefit won't ever be used, neither actively nor passively.-effectToBenefit :: Kind.COps -> Actor -> Effect.Effect Int -> Int-effectToBenefit Kind.COps{coactor=Kind.Ops{okind}} b eff =-  let kind = okind $ bkind b-  in case eff of-    Effect.NoEffect -> 0-    (Effect.Heal p) -> 10 * min p (Random.maxDice (ahp kind) - bhp b)-    (Effect.Hurt _ p) -> -(p * 10)     -- TODO: dice ignored, not capped-    Effect.Mindprobe{} -> 0            -- AI can't benefit yet-    Effect.Dominate -> -100-    (Effect.CallFriend p) -> p * 100-    Effect.Summon{} -> 1               -- may or may not spawn a friendly-    (Effect.CreateItem p) -> p * 20-    Effect.ApplyPerfume -> 0-    Effect.Regeneration{} -> 0         -- bigger benefit from carrying around-    Effect.Searching{} -> 0-    Effect.Ascend{} -> 0               -- change levels sensibly, in teams-    Effect.Escape{} -> 10000           -- AI wants to win; spawners to guard
+ Game/LambdaHack/Client/UI.hs view
@@ -0,0 +1,177 @@+-- | Ways for the client to use player input via UI to produce server+-- requests, based on the client's view (visualized for the player)+-- of the game state.+module Game.LambdaHack.Client.UI+  ( -- * Client UI monad+    MonadClientUI+    -- * Assorted UI operations+  , queryUI, pongUI+  , displayRespUpdAtomicUI, displayRespSfxAtomicUI+    -- * Startup+  , srtFrontend, KeyKind, SessionUI+    -- * Operations exposed for LoopClient+  , ColorMode(..), displayMore, msgAdd+    -- * Internal functions+  , humanCommand+  ) where++import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+import qualified Data.Map.Strict as M+import Data.Maybe++import Game.LambdaHack.Atomic+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+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.RunClient+import Game.LambdaHack.Client.UI.StartupFrontendClient+import Game.LambdaHack.Client.UI.WidgetClient+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.ModeKind++-- | Handle the move of a UI player.+queryUI :: MonadClientUI m => m RequestUI+queryUI = do+  cops <- getsState scops+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  let leader = 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}+      | isAllMoveFact cops fact && runMembers /= [leader] -> do+      stopRunning+      Config{configRunStopMsgs} <- askConfig+      let msg = if configRunStopMsgs+                then Just $ "Run stop: all-mover 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+  leader2 <- getLeaderUI+  if leader2 /= leader+    then return $! ReqUILeader leader2 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+  -- For human UI we invalidate whole @sbfsD@ at the start of each+  -- UI player input, which is an overkill, but doesn't affects+  -- screensavers, because they are UI, but not human.+  modifyClient $ \cli -> cli {sbfsD = EM.empty}+  let loop :: Maybe (Bool, Overlay) -> m 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 ->+            -- (Re-)display the last slide while waiting for the next key.+            return bLast+        (seqCurrent, seqPrevious, k) <- getsClient slastRecord+        case k of+          0 -> do+            let slastRecord = ([], seqCurrent, 0)+            modifyClient $ \cli -> cli {slastRecord}+          _ -> do+            let slastRecord = ([], seqCurrent ++ seqPrevious, k - 1)+            modifyClient $ \cli -> cli {slastRecord}+        km <- getKeyOverlayCommand lastBlank over+        -- Messages shown, so update history and reset current report.+        recordHistory+        abortOrCmd <- do+          -- Look up the key.+          Binding{bcmdMap} <- askBinding+          case M.lookup km 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+                              else 0}+              if km == K.escKM && isNothing stgtMode && isJust mover+                then cmdHumanSem Clear+                else cmdHumanSem cmd+            Nothing -> let msgKey = "unknown command <" <> K.showKM km <> ">"+                       in fmap Left $ promptToSlideshow msgKey+        -- The command was failed or successful and if the latter,+        -- possibly took some time.+        case abortOrCmd of+          Right cmdS ->+            -- Exit the loop and let other actors act. No next key needed+            -- and no slides could have been generated.+            return cmdS+          Left slides -> do+            -- If no time taken, rinse and repeat.+            -- Analyse the obtained slides.+            let (onBlank, sli) = slideshow slides+            mLast <- case sli of+              [] -> return Nothing+              [sLast] ->+                -- Avoid displaying the single slide twice.+                return $ Just (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+            loop mLast+  case msgRunStop of+    Nothing -> loop Nothing+    Just msg -> do+      sli <- promptToSlideshow msg+      loop $ Just (False, head . snd $ slideshow sli)++-- | Client signals to the server that it's still online, flushes frames+-- (if needed) and sends some extra info.+pongUI :: MonadClientUI m => m RequestUI+pongUI = do+  escPressed <- tryTakeMVarSescMVar+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  let pong ats = return $ ReqUIPong ats+      underAI = playerAI $ gplayer fact+  if escPressed && underAI && playerLeader (gplayer fact) then do+    -- Ask server to turn off AI for the faction's leader.+    let atomicCmd = UpdAtomic $ UpdAutoFaction side False+    pong [atomicCmd]+  else do+    -- Respond to the server normally, perhaps pinging the frontend, too.+    when underAI syncFrames+    pong []
+ Game/LambdaHack/Client/UI/Animation.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+-- | Screen frames and animations.+module Game.LambdaHack.Client.UI.Animation+  ( SingleFrame(..), decodeLine, encodeLine+  , overlayOverlay+  , Animation, Frames, renderAnim, restrictAnim+  , twirlSplash, blockHit, blockMiss, deathBody, swapPlaces, fadeout+  ) where++import Control.Exception.Assert.Sugar+import Data.Binary+import Data.Bits+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.List+import Data.Maybe+import Data.Monoid+import qualified Data.Vector.Generic as G+import GHC.Generics (Generic)++import Game.LambdaHack.Common.Color+import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random++decodeLine :: ScreenLine -> [AttrChar]+decodeLine v = map (toEnum . fromIntegral) $ G.toList v++-- | The data sufficent to draw a single game screen frame.+data SingleFrame = SingleFrame+  { sfLevel  :: ![ScreenLine]  -- ^ screen, from top to bottom, line by line+  , sfTop    :: !Overlay       -- ^ some extra lines to show over the top+  , sfBottom :: ![ScreenLine]  -- ^ some extra lines to show at the bottom+  , sfBlank  :: !Bool          -- ^ display only @sfTop@, on blank screen+  }+  deriving (Eq, Show, Generic)++instance Binary SingleFrame++-- | Overlays the @sfTop@ and @sfBottom@ fields onto the @sfLevel@ field.+-- The resulting frame has empty @sfTop@ and @sfBottom@.+-- To be used by simple frontends that don't display overlays+-- in separate windows/panes/scrolled views.+overlayOverlay :: SingleFrame -> SingleFrame+overlayOverlay SingleFrame{..} =+  let lxsize = fst normalLevelBound + 1  -- TODO+      lysize = snd normalLevelBound + 1+      emptyLine = encodeLine+                  $ replicate lxsize (Color.AttrChar Color.defAttr ' ')+      canvasLength = if sfBlank then lysize + 3 else lysize + 1+      canvas | sfBlank = replicate canvasLength emptyLine+             | otherwise = emptyLine : sfLevel+      topTrunc = overlay sfTop+      topLayer = if length topTrunc <= canvasLength+                 then topTrunc+                 else take (canvasLength - 1) topTrunc+                      ++ [toScreenLine "--a portion of the text trimmed--"]+      f layerLine canvasLine =+        layerLine G.++ G.drop (G.length layerLine) canvasLine+      picture = zipWith f topLayer canvas+      bottomLines = if sfBlank then [] else sfBottom+      newLevel = picture ++ drop (length picture) canvas ++ bottomLines+  in SingleFrame { sfLevel = newLevel+                 , sfTop = emptyOverlay+                 , sfBottom = []+                 , sfBlank }++-- | Animation is a list of frame modifications to play one by one,+-- where each modification if a map from positions to level map symbols.+newtype Animation = Animation [EM.EnumMap Point AttrChar]+  deriving (Eq, Show, Monoid)++-- | Sequences of screen frames, including delays.+type Frames = [Maybe SingleFrame]++-- | Render animations on top of a screen frame.+renderAnim :: X -> Y -> SingleFrame -> Animation -> Frames+renderAnim lxsize lysize basicFrame (Animation anim) =+  let modifyFrame SingleFrame{sfLevel = []} _ =+        assert `failure` (lxsize, lysize, basicFrame, anim)+      modifyFrame SingleFrame{sfLevel = levelOld, ..} am =+        let fLine y lineOld =+              let f l (x, acOld) =+                    let pos = Point x y+                        !ac = fromMaybe acOld $ EM.lookup pos am+                    in ac : l+              in foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld))+            sfLevel =  -- fully evaluated inside+              let f l (y, lineOld) = let !line = fLine y lineOld in line : l+              in map encodeLine+                 $ 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]++blank :: Maybe AttrChar+blank = Nothing++coloredSymbol :: Color -> Char -> Maybe AttrChar+coloredSymbol color symbol = Just $ AttrChar (Attr color defBG) symbol++mzipPairs :: (Point, Point) -> (Maybe AttrChar, Maybe AttrChar)+          -> [(Point, AttrChar)]+mzipPairs (p1, p2) (mattr1, mattr2) =+  let mzip (pos, mattr) = fmap (\x -> (pos, x)) mattr+  in catMaybes $ if p1 /= p2+                 then [mzip (p1, mattr1), mzip (p2, mattr2)]+                 else -- If actor affects himself, show only the effect,+                      -- not the action.+                      [mzip (p1, mattr1)]++restrictAnim :: ES.EnumSet Point -> Animation -> Animation+restrictAnim vis (Animation as) =+  let f imap =+        let common = EM.intersection imap $ EM.fromSet (const ()) vis+          in if EM.null common then Nothing else Just common+  in Animation $ mapMaybe f as++-- | 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)+  ]++-- | 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)+  ]++-- | 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)+  ]++-- | 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   ','+  ]++-- | 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)+  ]++fadeout :: Bool -> Bool -> Int -> X -> Y -> Rnd Animation+fadeout out topRight step lxsize lysize = do+  let xbound = lxsize - 1+      ybound = lysize - 1+      edge = EM.fromDistinctAscList $ zip [1..] ".%&%;:,."+      fadeChar r n x y =+        let d = x - 2 * y+            ndy = n - d - 2 * ybound+            ndx = n + d - xbound - 1  -- @-1@ for asymmetry+            mnx = if ndy > 0 && ndx > 0+                  then min ndy ndx+                  else max ndy ndx+            v3 = (r `xor` (x * y)) `mod` 3+            k | mnx < 3 || mnx > 10 = mnx+              | (min x (xbound - x - y) + n + v3) `mod` 15 < 11+                && mnx > 6 = mnx - v3+              | (x + 3 * y + v3) `mod` 30 < 19 = mnx + 1+              | otherwise = mnx+        in EM.findWithDefault ' ' k edge+      rollFrame n = do+        r <- random+        let l = [ ( Point (if topRight then x else xbound - x) y+                  , AttrChar defAttr $ fadeChar r n x y )+                | x <- [0..xbound]+                , y <- [max 0 (ybound - (n - x) `div` 2)..ybound]+                    ++ [0..min ybound ((n - xbound + x) `div` 2)]+                ]+        return $! EM.fromList 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
+ Game/LambdaHack/Client/UI/Config.hs view
@@ -0,0 +1,120 @@+-- | Personal game configuration file type definitions.+module Game.LambdaHack.Client.UI.Config+  ( Config(..), mkConfig, applyConfigToDebug+  ) where++import Control.DeepSeq+import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.Ini as Ini+import qualified Data.Ini.Reader as Ini+import qualified Data.Ini.Types as Ini+import Data.List+import qualified Data.Map.Strict as M+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import Game.LambdaHack.Common.ClientOptions+import System.Directory+import System.FilePath+import Text.Read++import qualified Game.LambdaHack.Client.Key as K+import Game.LambdaHack.Client.UI.HumanCmd+import Game.LambdaHack.Common.File+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Content.RuleKind++-- | Fully typed contents of the UI config file. This config+-- is a part of a game client.+data Config = Config+  { -- commands+    configCommands    :: ![(K.KM, ([CmdCategory], HumanCmd))]+    -- hero names+  , configHeroNames   :: ![(Int, (Text, Text))]+    -- ui+  , configVi          :: !Bool  -- ^ the option for Vi keys takes precendence+  , configLaptop      :: !Bool  -- ^ because the laptop keys are the default+  , configFont        :: !String+  , configHistoryMax  :: !Int+  , configMaxFps      :: !Int+  , configNoAnim      :: !Bool+  , configRunStopMsgs :: !Bool+  }+  deriving Show++instance NFData Config++parseConfig :: Ini.Config -> Config+parseConfig cfg =+  let configCommands =+        let mkCommand (ident, keydef) =+              case stripPrefix "Macro_" ident of+                Just _ ->+                  let (key, def) = read keydef+                  in (K.mkKM key, def :: ([CmdCategory], HumanCmd))+                Nothing -> assert `failure` "wrong macro id" `twith` ident+            section = Ini.allItems "extra_commands" cfg+        in map mkCommand section+      configHeroNames =+        let toNumber (ident, nameAndPronoun) =+              case stripPrefix "HeroName_" ident of+                Just n -> (read n, read nameAndPronoun)+                Nothing -> assert `failure` "wrong hero name id" `twith` ident+            section = Ini.allItems "hero_names" cfg+        in map toNumber section+      getOption :: forall a. Read a => String -> a+      getOption optionName =+        let lookupFail :: forall b. String -> b+            lookupFail err =+              assert `failure` ("config file access failed:" <+> T.pack err)+                     `twith` (optionName, cfg)+            s = fromMaybe (lookupFail "") $ Ini.getOption "ui" optionName cfg+        in either lookupFail id $ readEither s+      configVi = getOption "movementViKeys_hjklyubn"+      -- The option for Vi keys takes precendence,+      -- because the laptop keys are the default.+      configLaptop = not configVi && getOption "movementLaptopKeys_uk8o79jl"+      configFont = getOption "font"+      configHistoryMax = getOption "historyMax"+      configMaxFps = max 1 $ getOption "maxFps"+      configNoAnim = getOption "noAnim"+      configRunStopMsgs = getOption "runStopMsgs"+  in Config{..}++-- | Read and parse UI config file.+mkConfig :: Kind.Ops RuleKind -> IO Config+mkConfig 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+      cfgUIDefault = either (assert `failure`) id $ Ini.parse sUIDefault+  dataDir <- appDataDir+  let userPath = dataDir </> cfgUIName <.> "ini"+  cfgUser <- do+    cpExists <- doesFileExist userPath+    if not cpExists+      then return Ini.emptyConfig+      else do+        sUser <- readFile userPath+        return $! either (assert `failure`) id $ Ini.parse sUser+  let cfgUI = M.unionWith M.union cfgUser cfgUIDefault  -- user cfg preferred+      conf = parseConfig cfgUI+  -- Catch syntax errors in complex expressions ASAP,+  return $! deepseq conf conf++applyConfigToDebug :: Config -> DebugModeCli -> Kind.Ops RuleKind+                   -> DebugModeCli+applyConfigToDebug sconfig sdebugCli corule =+  let stdRuleset = Kind.stdRuleset corule+  in (\dbg -> dbg {sfont =+        sfont dbg `mplus` Just (configFont sconfig)}) .+     (\dbg -> dbg {smaxFps =+        smaxFps dbg `mplus` Just (configMaxFps sconfig)}) .+     (\dbg -> dbg {snoAnim =+        snoAnim dbg `mplus` Just (configNoAnim sconfig)}) .+     (\dbg -> dbg {ssavePrefixCli =+        ssavePrefixCli dbg `mplus` Just (rsavePrefix stdRuleset)})+     $ sdebugCli
+ Game/LambdaHack/Client/UI/Content/KeyKind.hs view
@@ -0,0 +1,13 @@+-- | The type of key-command mappings to be used for the UI.+module Game.LambdaHack.Client.UI.Content.KeyKind+  ( KeyKind(..)+  ) where++import qualified Game.LambdaHack.Client.Key as K+import Game.LambdaHack.Client.UI.HumanCmd++-- | Key-command mappings to be used for the UI.+data KeyKind = KeyKind+  { rhumanCommands :: ![(K.KM, ([CmdCategory], HumanCmd))]+                                   -- ^ default client UI commands+  }
+ Game/LambdaHack/Client/UI/DisplayAtomicClient.hs view
@@ -0,0 +1,701 @@+-- | Display atomic commands received by the client.+module Game.LambdaHack.Client.UI.DisplayAtomicClient+  ( displayRespUpdAtomicUI, displayRespSfxAtomicUI+  ) where++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.Tuple+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.CommonClient+import Game.LambdaHack.Client.ItemSlot+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.Animation+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 qualified Game.LambdaHack.Common.Color as Color+import qualified Game.LambdaHack.Common.Dice as Dice+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemDescription+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 Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.TileKind++-- * RespUpdAtomicUI++-- TODO: let user configure which messages are not created, which are+-- slightly hidden, which are shown and which flash and center screen+-- and perhaps highligh the related location/actor. Perhaps even+-- switch to the actor, changing HP displayed on screen, etc.+-- but it's too short a clip to read the numbers, so probably+-- highlighing should be enough.+-- TODO: for a start, flesh out the verbose variant and then add+-- a single client debug option that flips verbosity+--+-- | Visualize atomic actions sent to the client. This is done+-- in the global state after the command is executed and after+-- the client state is modified by the command.+displayRespUpdAtomicUI :: MonadClientUI m+                       => Bool -> State -> StateClient -> UpdAtomic -> m ()+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+    destroyActorUI aid body "die" "be destroyed" verbose+    side <- getsClient sside+    when (bfid body == side && not (bproj body)) stopPlayBack+  UpdCreateItem iid _ k c -> do+    -- TODO: probably not Nothing if container not CGround+    updateItemSlot Nothing iid+    itemVerbMU iid k (MU.Text $ "appear" <+> ppContainer c) (storeFromC c)+    stopPlayBack+  UpdDestroyItem iid _ k c -> itemVerbMU iid k "disappear" (storeFromC 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 _ k 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+        updateItemSlot Nothing iid+        case c of+          CActor{} -> return ()  -- not actionable at this time+          CFloor lid p -> do+            scursorOld <- getsClient scursor+            case scursorOld of+              TEnemy{} -> return ()  -- probably too important to overwrite+              TEnemyPos{} -> return ()+              _ -> modifyClient $ \cli -> cli {scursor = TPoint lid p}+            itemVerbMU iid k "be spotted" CGround+            stopPlayBack+          CTrunk{} -> return ()+      _ -> return ()  -- seen recently (still has a slot assigned)+  UpdLoseItem{} -> skip+  -- Move actors and items.+  UpdMoveActor aid _ _ -> lookAtMove aid+  UpdWaitActor aid _ -> when verbose $ aVerbMU aid "wait"+  UpdDisplaceActor source target -> displaceActorUI source target+  UpdMoveItem iid k aid c1 c2 -> moveItemUI verbose iid k aid c1 c2+  -- Change actor attributes.+  UpdAgeActor{} -> skip+  UpdRefillHP aid n -> do+    when verbose $+      aVerbMU aid $ MU.Text $ (if n > 0 then "heal" else "lose")+                              <+> tshow (abs n) <> "HP"+    mleader <- getsClient _sleader+    when (Just aid == mleader) $ do+      b <- getsState $ getActorBody aid+      hpMax <- sumOrganEqpClient Effect.EqpSlotAddMaxHP aid+      when (bhp b == xM hpMax && hpMax > 0) $ do+        actorVerbMU aid b "recover your health fully"+        stopPlayBack+  UpdRefillCalm aid calmDelta ->+    when (calmDelta == minusM) $ do  -- lower deltas come from hits; obvious+      side <- getsClient sside+      b <- getsState $ getActorBody aid+      when (bfid b == side) $ do+        fact <- getsState $ (EM.! bfid b) . sfactionD+        allFoes  <- getsState $ actorRegularList (isAtWar fact) (blid b)+        let closeFoes = filter ((<= 3) . chessDist (bpos b) . bpos) allFoes+        when (null closeFoes) $ do  -- obvious where the feeling comes from+          aVerbMU aid "hear something"+          msgDuplicateScrap+  UpdOldFidActor{} -> skip+  UpdTrajectory{} -> skip+  UpdColorActor{} -> skip+  -- Change faction attributes.+  UpdQuitFaction fid mbody _ toSt -> quitFactionUI fid mbody toSt+  UpdLeadFaction fid (Just source) (Just target) -> do+    cops <- getsState scops+    side <- getsClient sside+    when (fid == side) $ do+      fact <- getsState $ (EM.! side) . sfactionD+      -- All-movers can't run with multiple actors, so the following is not+      -- a leader change while running, but rather server changing+      -- their leader, which the player should be alerted to.+      when (isAllMoveFact cops fact) stopPlayBack+      actorD <- getsState sactorD+      case EM.lookup source actorD of+        Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do+          -- Regardless who the leader is, give proper names here, not 'you'.+          tb <- getsState $ getActorBody target+          let subject = partActor tb+              object  = partActor sb+          msgAdd $ makeSentence [ MU.SubjectVerbSg subject "take command"+                                , "from", object ]+        _ ->+          return ()+          -- 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+  UpdDiplFaction fid1 fid2 _ toDipl -> do+    name1 <- getsState $ gname . (EM.! fid1) . sfactionD+    name2 <- getsState $ gname . (EM.! fid2) . sfactionD+    let showDipl Unknown = "unknown to each other"+        showDipl Neutral = "in neutral diplomatic relations"+        showDipl Alliance = "allied"+        showDipl War = "at war"+    msgAdd $ name1 <+> "and" <+> name2 <+> "are now" <+> showDipl toDipl <> "."+  UpdAutoFaction{} -> skip+  UpdRecordKill{} -> skip+  -- Alter map.+  UpdAlterTile{} -> when verbose $ return ()  -- TODO: door opens+  UpdAlterClear _ k -> msgAdd $ if k > 0+                                then "You hear grinding noises."+                                else "You hear fizzing noises."+  UpdSearchTile aid p fromTile toTile -> do+    Kind.COps{cotile = Kind.Ops{okind}} <- getsState scops+    b <- getsState $ getActorBody aid+    lvl <- getLevel $ blid b+    subject <- partAidLeader aid+    let t = lvl `at` p+        verb | t == toTile = "confirm"+             | otherwise = "reveal"+        subject2 = MU.Text $ tname $ okind fromTile+        verb2 = "be"+    let msg = makeSentence [ MU.SubjectVerbSg subject verb+                           , "that the"+                           , MU.SubjectVerbSg subject2 verb2+                           , "a hidden"+                           , MU.Text $ tname $ okind toTile ]+    msgAdd msg+  UpdLearnSecrets{} -> skip+  UpdSpotTile{} -> skip+  UpdLoseTile{} -> skip+  UpdAlterSmell{} -> skip+  UpdSpotSmell{} -> skip+  UpdLoseSmell{} -> skip+  -- Assorted.+  UpdAgeGame {} -> skip+  UpdDiscover _ _ iid _ _ -> discover oldStateClient iid+  UpdCover{} ->  skip  -- don't spam when doing undo+  UpdDiscoverKind _ _ iid _ -> discover oldStateClient iid+  UpdCoverKind{} ->  skip  -- don't spam when doing undo+  UpdDiscoverSeed _ _ iid _ -> discover oldStateClient iid+  UpdCoverSeed{} -> skip  -- don't spam when doing undo+  UpdPerception{} -> skip+  UpdRestart _ _ _ _ _ _ -> do+    mode <- getModeClient+    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.+    history <- getsClient shistory+    when (lengthHistory history > 1) $ fadeOutOrIn False+  UpdRestartServer{} -> skip+  UpdResume{} -> skip+  UpdResumeServer{} -> skip+  UpdKillExit{} -> skip+  UpdSaveBkp -> when verbose $ msgAdd "Saving backup."+  UpdMsgAll msg -> msgAdd msg+  UpdRecordHistory _ -> recordHistory++lookAtMove :: MonadClientUI m => ActorId -> m ()+lookAtMove aid = do+  body <- getsState $ getActorBody aid+  side <- getsClient sside+  tgtMode <- getsClient stgtMode+  when (not (bproj body)+        && bfid body == side+        && isNothing tgtMode) $ do  -- targeting does a more extensive look+    lookMsg <- lookAt False "" True (bpos body) aid ""+    msgAdd lookMsg+  fact <- getsState $ (EM.! bfid body) . sfactionD+  if side == bfid body then do+    foes <- getsState $ actorList (isAtWar fact) (blid body)+    when (any (adjacent (bpos body) . bpos) foes) stopPlayBack+  else when (isAtWar fact side) $ do+    friends <- getsState $ actorRegularList (== side) (blid body)+    when (any (adjacent (bpos body) . bpos) friends) stopPlayBack++-- | Sentences such as \"Dog barks loudly.\".+actorVerbMU :: MonadClientUI m => ActorId -> Actor -> MU.Part -> m ()+actorVerbMU aid b verb = do+  subject <- partActorLeader aid b+  msgAdd $ makeSentence [MU.SubjectVerbSg subject verb]++aVerbMU :: MonadClientUI m => ActorId -> MU.Part -> m ()+aVerbMU aid verb = do+  b <- getsState $ getActorBody aid+  actorVerbMU aid b verb++itemVerbMU :: MonadClientUI m+           => ItemId -> Int -> MU.Part -> CStore -> m ()+itemVerbMU iid k verb cstore = assert (k > 0) $ do+  itemToF <- itemToFullClient+  let subject = partItemWs k cstore (itemToF iid k)+      msg | k > 1 = makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes subject verb]+          | otherwise = makeSentence [MU.SubjectVerbSg subject verb]+  msgAdd msg++aiVerbMU :: MonadClientUI m+         => ActorId -> MU.Part -> ItemId -> Int -> CStore -> m ()+aiVerbMU aid verb iid k cstore = do+  itemToF <- itemToFullClient+  subject <- partAidLeader aid+  let msg = makeSentence [ MU.SubjectVerbSg subject verb+                         , partItemWs k cstore (itemToF iid k) ]+  msgAdd msg++msgDuplicateScrap :: MonadClientUI m => m ()+msgDuplicateScrap = do+  report <- getsClient sreport+  history <- getsClient shistory+  let (lastMsg, repRest) = lastMsgOfReport report+      lastDup = isJust . findInReport (== lastMsg)+      lastDuplicated = lastDup repRest+                       || maybe False lastDup (lastReportOfHistory history)+  when lastDuplicated $+    modifyClient $ \cli -> cli {sreport = repRest}++-- TODO: "XXX spots YYY"? or blink or show the changed cursor?+createActorUI :: MonadClientUI m => ActorId -> Actor -> Bool -> MU.Part -> m ()+createActorUI aid body verbose verb = do+  side <- getsClient sside+  when (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+      -- Target even if nobody can aim at the enemy. Let's home in on him+      -- and then we can aim or melee. We set permit to False, because it's+      -- technically very hard to check aimability here, because we are+      -- in-between turns and, e.g., leader's move has not yet been taken+      -- into account.+      modifyClient $ \cli -> cli {scursor = TEnemy aid False}+    stopPlayBack+  when (bfid body == side && not (bproj body)) $ lookAtMove aid++destroyActorUI :: MonadClientUI m+               => ActorId -> Actor -> MU.Part -> MU.Part -> Bool -> m ()+destroyActorUI aid body verb verboseVerb verbose = do+  side <- getsClient sside+  if (bfid body == side && bhp body <= 0 && not (bproj body)) then do+    actorVerbMU aid body verb+    void $ displayMore ColorBW ""+  else when verbose $ actorVerbMU aid body verboseVerb++moveItemUI :: MonadClientUI m+           => Bool -> ItemId -> Int -> ActorId -> CStore -> CStore+           -> m ()+moveItemUI verbose iid k aid c1 c2 = do+  side <- getsClient sside+  b <- getsState $ getActorBody aid+  case (c1, c2) of+    (_, _) | c1 == CGround -> do+      when (bfid b == side) $ updateItemSlot (Just aid) iid+      fact <- getsState $ (EM.! bfid b) . sfactionD+      let underAI = playerAI $ gplayer fact+      mleader <- getsClient _sleader+      if Just aid == mleader && not underAI then do+        itemToF <- itemToFullClient+        (letterSlots, _) <- getsClient sslots+        bag <- getsState $ getCBag $ CActor aid c2+        let n = bag EM.! iid+        case lookup iid $ map swap $ EM.assocs letterSlots of+          Just l -> msgAdd $ makePhrase+                      [ "\n"+                      , slotLabel $ Left l+                      , "-"+                      , partItemWs n c2 (itemToF iid n)+                      , "\n" ]+          Nothing -> return ()+      else when (c1 == CGround && c1 /= c2) $+        aiVerbMU aid "get" iid k c2+    (_, CGround) | c1 /= c2 -> do+      when verbose $ aiVerbMU aid "drop" iid k c1+      if bfid b == side+        then updateItemSlot (Just aid) iid+        else updateItemSlot Nothing iid+    _ -> return ()++displaceActorUI :: MonadClientUI m => ActorId -> ActorId -> m ()+displaceActorUI source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  spart <- partActorLeader source sb+  tpart <- partActorLeader target tb+  let msg = makeSentence [MU.SubjectVerbSg spart "displace", tpart]+  msgAdd msg+  when (bfid sb /= bfid tb) $ do+    lookAtMove source+    lookAtMove target+  let ps = (bpos tb, bpos sb)+  animFrs <- animate (blid sb) $ swapPlaces ps+  displayActorStart sb animFrs++quitFactionUI :: MonadClientUI m+              => FactionId -> Maybe Actor -> Maybe Status -> m ()+quitFactionUI fid mbody toSt = do+  cops@Kind.COps{coitem=Kind.Ops{okind, ouniqGroup}} <- getsState scops+  fact <- getsState $ (EM.! fid) . sfactionD+  let fidName = MU.Text $ gname fact+      horror = isHorrorFact cops fact+  side <- getsClient sside+  let msgIfSide _ | fid /= side = Nothing+      msgIfSide s = Just s+      (startingPart, partingPart) = case toSt of+        _ | horror ->+          (Nothing, Nothing)  -- Ignore summoned actors' factions.+        Just Status{stOutcome=Killed} ->+          ( Just "be eliminated"+          , msgIfSide "Let's hope another party can save the day!" )+        Just Status{stOutcome=Defeated} ->+          ( Just "be decisively defeated"+          , msgIfSide "Let's hope your new overlords let you live." )+        Just Status{stOutcome=Camping} ->+          ( Just "order save and exit"+          , Just $ if fid == side+                   then "See you soon, stronger and braver!"+                   else "See you soon, stalwart warrior!" )+        Just Status{stOutcome=Conquer} ->+          ( Just "vanquish all foes"+          , msgIfSide "Can it be done in a better style, though?" )+        Just Status{stOutcome=Escape} ->+          ( Just "achieve victory"+          , msgIfSide "Can it be done better, though?" )+        Just Status{stOutcome=Restart, stInfo} ->+          ( Just $ MU.Text $ "order mission restart in" <+> stInfo <+> "mode"+          , Just $ if fid == side+                   then "This time for real."+                   else "Somebody couldn't stand the heat." )+        Nothing ->+          (Nothing, Nothing)  -- Wipe out the quit flag for the savegame files.+  case startingPart of+    Nothing -> return ()+    Just sp -> do+      let msg = makeSentence [MU.SubjectVerbSg fidName sp]+      msgAdd msg+  case (toSt, partingPart) of+    (Just status, Just pp) -> do+      (bag, total) <- case mbody of+        Just body | fid == side -> getsState $ calculateTotal body+        _ -> case gleader fact of+          Nothing -> return (EM.empty, 0)+          Just aid -> do+            b <- getsState $ getActorBody aid+            getsState $ calculateTotal b+      let currencyName = MU.Text $ iname $ okind $ ouniqGroup "currency"+          itemMsg = makeSentence [ "Your loot is worth"+                                 , MU.CarWs total currencyName ]+                    <+> moreMsg+      startingSlide <- promptToSlideshow moreMsg+      recordHistory  -- we are going to exit or restart, so record+      itemSlides <-+        if EM.null bag then return mempty+        else do+          io <- itemOverlay CGround bag+          overlayToSlideshow itemMsg io+      -- Show score for any UI client, even though it is saved only+      -- for human UI clients.+      scoreSlides <- scoreToSlideshow total status+      partingSlide <- promptToSlideshow $ pp <+> moreMsg+      shutdownSlide <- promptToSlideshow pp+      -- TODO: First ESC cancels items display.+      void $ getInitConfirms ColorFull []+           $ startingSlide <> itemSlides+      -- TODO: Second ESC cancels high score and parting message display.+      -- The last slide stays onscreen during shutdown, etc.+             <> scoreSlides <> partingSlide <> shutdownSlide+      -- TODO: perhaps use a vertical animation instead, e.g., roll down+      -- and put it before item and score screens (on blank background)+      unless (fmap stOutcome toSt == Just Camping) $ fadeOutOrIn True+    _ -> return ()++discover :: MonadClientUI m => StateClient -> ItemId ->  m ()+discover oldcli iid = do+  cops <- getsState scops+  itemToF <- itemToFullClient+  let itemFull = itemToF iid 1+      (knownName, knownAEText) = partItem CGround 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 CGround itemSecret+      msg = makeSentence+        [ "the", MU.SubjectVerbSg (MU.Phrase [secretName, secretAEText])+                                  "turn out to be"+        , MU.AW $ MU.Phrase [knownName, knownAEText] ]+      oldItemFull =+        itemToFull cops (sdisco oldcli) (sdiscoAE 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 CEqp itemFull /= textAllAE False CEqp oldItemFull) $+    msgAdd msg++-- * RespSfxAtomicUI++-- | 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+    spart <- partAidLeader source+    tpart <- partAidLeader target+    msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink away from", tpart]+  SfxProject aid iid -> aiVerbMU aid "aim" iid 1 CInv+  SfxCatch aid iid -> aiVerbMU aid "catch" iid 1 CInv+  SfxActivate aid iid k -> aiVerbMU aid "activate" iid k CInv+  SfxCheck aid iid k -> aiVerbMU aid "deactivate" iid k CInv+  SfxTrigger aid _p _feat ->+    when verbose $ aVerbMU aid "trigger"  -- TODO: opens door, etc.+  SfxShun aid _p _ ->+    when verbose $ aVerbMU aid "shun"  -- TODO: shuns stairs down+  SfxEffect fidSource aid effect -> do+    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.+      let firstFall | fid == side && bproj b = "fall apart"+                    | fid == side = "fall down"+                    | bproj b = "break up"+                    | otherwise = "collapse"+          hurtExtra | fid == side && bproj b = "be reduced to dust"+                    | 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) =+            case effect of+              Effect.Hurt p | deadPreviousTurn (xM $ Dice.maxDice p) ->+                (True, hurtExtra)+              Effect.RefillHP 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+    else case effect of+        Effect.NoEffect t -> msgAdd $ "Nothing happens." <+> t+        Effect.RefillHP p | p == 1 -> skip  -- no spam from regen items+        Effect.RefillHP p | p > 0 -> do+          if fid == side then+            actorVerbMU aid b "feel healthier"+          else+            actorVerbMU aid b "look healthier"+          let ps = (bpos b, bpos b)+          animFrs <- animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue+          displayActorStart b animFrs+        Effect.RefillHP _ -> do+          if fid == side then+            actorVerbMU aid b "feel wounded"+          else+            actorVerbMU aid b "look wounded"+          let ps = (bpos b, bpos b)+          animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red+          displayActorStart b animFrs+        Effect.Hurt{} -> skip  -- avoid spam; SfxStrike just sent+        Effect.RefillCalm p | p == 1 -> skip  -- no spam from regen items+        Effect.RefillCalm p | p > 0 -> do+          if fid == side then+            actorVerbMU aid b "feel calmer"+          else+            actorVerbMU aid b "look calmer"+          let ps = (bpos b, bpos b)+          animFrs <- animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue+          displayActorStart b animFrs+        Effect.RefillCalm _ -> do+          if fid == side then+            actorVerbMU aid b "feel agitated"+          else+            actorVerbMU aid b "look agitated"+          let ps = (bpos b, bpos b)+          animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red+          displayActorStart b animFrs+        Effect.Dominate -> do+          -- 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+              aVerbMU aid $ MU.Text "yield, under extreme pressure"+            else if fid == side then+              aVerbMU aid $ MU.Text "black out, dominated by foes"+            else+              aVerbMU aid $ MU.Text "decide abrubtly to switch allegiance"+            fidName <- getsState $ gname . (EM.! fid) . sfactionD+            let verb = "be no longer controlled by"+            msgAdd $ makeSentence+              [MU.SubjectVerbSg subject verb, MU.Text fidName]+            when (fid == side) $ void $ displayMore ColorFull ""+          else do+            fidSourceName <- getsState $ gname . (EM.! fidSource) . sfactionD+            let verb = "be now under"+            msgAdd $ makeSentence+              [MU.SubjectVerbSg subject verb, MU.Text fidSourceName, "control"]+        Effect.Impress{} ->+          actorVerbMU aid b+          $ if boldfid b /= bfid b+            then+              "get sobered and refocused by the fragrant moisture"+            else+              "inhale the sweet smell that weakens resolve and erodes loyalty"+        Effect.CallFriend{} -> skip+        Effect.Summon{} -> skip+        Effect.CreateItem{} -> skip+        Effect.ApplyPerfume ->+          msgAdd "The fragrance quells all scents in the vicinity."+        Effect.Burn{} ->+          if fid == side then+            actorVerbMU aid b "feel burned"+          else+            actorVerbMU aid b "look burned"+        Effect.Ascend k | k > 0 -> actorVerbMU aid b "find a way upstairs"+        Effect.Ascend k | k < 0 -> actorVerbMU aid b "find a way downstairs"+        Effect.Ascend{} -> assert `failure` sfx+        Effect.Escape{} -> skip+        Effect.Paralyze{} -> actorVerbMU aid b "be paralyzed"+        Effect.InsertMove{} -> actorVerbMU aid b "move with extreme speed"+        Effect.DropBestWeapon -> actorVerbMU aid b "be disarmed"+        Effect.DropEqp _ False -> actorVerbMU aid b "be stripped"  -- TODO+        Effect.DropEqp _ True -> actorVerbMU aid b "be violently stripped"+        Effect.SendFlying{} -> actorVerbMU aid b "be sent flying"+        Effect.PushActor{} -> actorVerbMU aid b "be pushed"+        Effect.PullActor{} -> actorVerbMU aid b "be pulled"+        Effect.Teleport t | t > 9 -> actorVerbMU aid b "teleport"+        Effect.Teleport{} -> actorVerbMU aid b "blink"+        Effect.PolyItem cstore -> do+          allAssocs <- fullAssocsClient aid [cstore]+          case allAssocs of+            [] -> return ()  -- invisible items?+            (_, ItemFull{..}) : _ -> do+              let itemSecret = itemNoDisco (itemBase, itemK)+                  (secretName, secretAEText) = partItem cstore itemSecret+                  subject = partActor b+                  verb = "repurpose"+                  store = MU.Text $ ppCStore cstore+              msgAdd $ makeSentence+                [ MU.SubjectVerbSg subject verb+                , "the", secretName, secretAEText, store ]+        Effect.Identify cstore -> do+          allAssocs <- fullAssocsClient aid [cstore]+          case allAssocs of+            [] -> return ()  -- invisible items?+            (_, ItemFull{..}) : _ -> do+              let itemSecret = itemNoDisco (itemBase, itemK)+                  (secretName, secretAEText) = partItem cstore itemSecret+                  subject = partActor b+                  verb = "compare"+                  store = MU.Text $ ppCStore cstore+              msgAdd $ makeSentence+                [ MU.SubjectVerbSg subject verb+                , "old notes with the", secretName, secretAEText, store ]+        Effect.ActivateInv{} -> skip+        Effect.Explode{} -> skip  -- lots of visual feedback+        Effect.OneOf{} -> skip+        Effect.OnSmash{} -> assert `failure` sfx+        Effect.TimedAspect{} -> skip  -- TODO+  SfxMsgFid _ msg -> msgAdd msg+  SfxMsgAll msg -> msgAdd msg+  SfxActorStart aid -> do+    arena <- getArenaUI+    b <- getsState $ getActorBody 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)+      -- 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.+      timeCutOff <- getsClient $ EM.findWithDefault timeZero arena . sdisplayed+      when (btime b >= timeShift timeCutOff (Delta timeClip)+            || 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 = playerAI $ gplayer fact+        unless (Just aid == mleader && not underAI) $+          -- 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++strike :: MonadClientUI m+       => ActorId -> ActorId -> ItemId -> HitAtomic -> m ()+strike source target iid hitStatus = assert (source /= target) $ do+  itemToF <- itemToFullClient+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  spart <- partActorLeader source sb+  tpart <- partActorLeader target tb+  spronoun <- partPronounLeader source sb+  let itemFull = itemToF iid 1+      verb = case itemDisco itemFull of+        Nothing -> "hit"  -- not identified+        Just ItemDisco{itemKind} -> iverbHit itemKind+      isOrgan = iid `EM.member` borgan sb+      partItemChoice = if isOrgan+                       then partItemWownW spronoun COrgan+                       else partItemAW CEqp+      msg HitClear = makeSentence $+        [MU.SubjectVerbSg spart verb, tpart]+        ++ if bproj sb+           then []+           else ["with", partItemChoice itemFull]+      msg (HitBlock n) =+        let sActs =+              if bproj sb+              then [ MU.SubjectVerbSg spart "connect" ]+              else [ MU.SubjectVerbSg spart "swing"+                   , partItemChoice itemFull ]+        in makeSentence [ MU.Phrase sActs MU.:> ", but"+                        , MU.SubjectVerbSg tpart "block"+                        , if n > 1 then "doggedly" else "partly"+                        ]+-- TODO: when other armor is in, etc.:+--      msg HitSluggish =+--        let adv = MU.Phrase ["sluggishly", verb]+--        in makeSentence $ [MU.SubjectVerbSg spart adv, tpart]+--                          ++ ["with", partItemChoice itemFull]+  msgAdd $ msg hitStatus+  let ps = (bpos tb, bpos sb)+      anim HitClear = twirlSplash ps Color.BrRed Color.Red+      anim (HitBlock 1) = blockHit ps Color.BrRed Color.Red+      anim (HitBlock _) = blockMiss ps+  animFrs <- animate (blid sb) $ anim hitStatus+  displayActorStart sb animFrs
+ Game/LambdaHack/Client/UI/DrawClient.hs view
@@ -0,0 +1,384 @@+-- | Display game data on the screen using one of the available frontends+-- (determined at compile time with cabal flags).+module Game.LambdaHack.Client.UI.DrawClient+  ( ColorMode(..)+  , draw+  ) where++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.Text (Text)+import qualified Data.Text as T++import Game.LambdaHack.Client.Bfs+import Game.LambdaHack.Client.CommonClient+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.Animation+import Game.LambdaHack.Common.Actor as Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Color as Color+import qualified Game.LambdaHack.Common.Dice as Dice+import qualified Game.LambdaHack.Common.Effect as Effect+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 qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.TileKind++-- | Color mode for the display.+data ColorMode =+    ColorFull  -- ^ normal, with full colours+  | ColorBW    -- ^ black+white only++-- TODO: split up and generally rewrite.+-- | Draw the whole screen: level map and status area.+-- Pass at most a single page if overlay of text unchanged+-- to the frontends to display separately or overlay over map,+-- depending on the frontend.+draw :: MonadClient m+     => Bool -> 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+     (cursorDesc, mcursorHP) (targetDesc, mtargetHP) sfTop = do+  cops <- getsState scops+  mleader <- getsClient _sleader+  s <- getState+  cli@StateClient{ stgtMode, seps, sexplored+                 , smarkVision, smarkSmell, smarkSuspect, swaitTimes }+    <- getClient+  per <- getPerFid drawnLevelId+  let Kind.COps{cotile=cotile@Kind.Ops{okind=tokind, ouniqGroup}} = cops+      (lvl@Level{lxsize, lysize, lsmell, ltime}) = sdungeon s EM.! drawnLevelId+      (bl, mblid, mbpos) = case (cursorPos, mleader) of+        (Just cursor, Just leader) ->+          let Actor{bpos, blid} = getActorBody leader s+          in if blid /= drawnLevelId+             then ( [cursor], Just blid, Just bpos )+             else ( fromMaybe [] $ bla lxsize lysize seps bpos cursor+                  , Just blid+                  , Just bpos )+        _ -> ([], Nothing, Nothing)+      mpath = maybe Nothing (\(_, mp) -> if null bl+                                            || mblid /= Just drawnLevelId+                                         then Nothing+                                         else mp) bfsmpathRaw+      actorsHere = actorAssocs (const True) drawnLevelId s+      cursorHere = find (\(_, m) -> cursorPos == Just (Actor.bpos m))+                   actorsHere+      shiftedBTrajectory = case cursorHere of+        Just (_, Actor{btrajectory = Just p, bpos = prPos}) ->+          trajectoryToPath prPos (fst p)+        _ -> []+      unknownId = ouniqGroup "unknown space"+      dis pos0 =+        let tile = lvl `at` pos0+            tk = tokind tile+            floorBag = lvl `atI` pos0+            (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+            sml = EM.findWithDefault timeZero pos0 lsmell+            smlt = sml `timeDeltaToFrom` ltime+            viewActor aid Actor{bsymbol, bcolor, bhp, bproj}+              | Just aid == mleader = (symbol, inverseVideo)+              | otherwise = (symbol, Color.defAttr {Color.fg = bcolor})+             where+              symbol | bhp <= 0 && not bproj = '%'+                     | otherwise = bsymbol+            rainbow p = Color.defAttr {Color.fg =+                                         toEnum $ fromEnum p `rem` 14 + 1}+            -- smarkSuspect is an optional overlay, so let's overlay it+            -- over both visible and invisible tiles.+            vcolor+              | smarkSuspect && Tile.isSuspect cotile tile = Color.BrCyan+              | vis = tcolor tk+              | otherwise = tcolor2 tk+            fgOnPathOrLine = case (vis, Tile.isWalkable cotile tile) of+              _ | tile == unknownId -> Color.BrBlack+              _ | Tile.isSuspect cotile tile -> Color.BrCyan+              (True, True)   -> Color.BrGreen+              (True, False)  -> Color.BrRed+              (False, True)  -> Color.Green+              (False, False) -> Color.Red+            atttrOnPathOrLine = if Just pos0 == cursorPos+                                then inverseVideo {Color.fg = fgOnPathOrLine}+                                else Color.defAttr {Color.fg = fgOnPathOrLine}+            (char, attr0) =+              case find (\(_, m) -> pos0 == Actor.bpos m) actorsHere of+                _ | isJust stgtMode+                    && (elem pos0 bl || elem pos0 shiftedBTrajectory) ->+                  ('*', atttrOnPathOrLine)  -- line takes precedence over path+                _ | isJust stgtMode+                    && (maybe False (elem pos0) mpath) ->+                  (';', Color.defAttr {Color.fg = fgOnPathOrLine})+                Just (aid, m) -> viewActor aid m+                _ | smarkSmell && smlt > Delta timeZero ->+                  (timeDeltaToDigit smellTimeout smlt, rainbow pos0)+                  | otherwise ->+                  case floorIids of+                    [] -> (tsymbol tk, Color.defAttr {Color.fg = vcolor})+                    iid : _ -> viewItem $ getItemBody iid s+            vis = ES.member pos0 $ totalVisible per+            a = case dm of+                  ColorBW -> Color.defAttr+                  ColorFull -> if smarkVision && vis+                               then attr0 {Color.bg = Color.Blue}+                               else attr0+        in Color.AttrChar a char+      widthX = 80+      widthTgt = 39+      widthStats = widthX - widthTgt+      addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)+      arenaStatus = drawArenaStatus (ES.member drawnLevelId sexplored) lvl+                                    widthStats+      displayPathText mp mt =+        let (plen, llen) = case (mp, bfsmpathRaw, mbpos) of+              (Just target, Just (bfs, _), Just bpos)+                | mblid == Just drawnLevelId ->+                  (fromMaybe 0 (accessBfs bfs target), chessDist bpos target)+              _ -> (0, 0)+            pText | plen == 0 = ""+                  | otherwise = "p" <> tshow plen+            lText | llen == 0 = ""+                  | otherwise = "l" <> tshow llen+            text = fromMaybe (pText <+> lText) mt+        in if T.null text then "" else " " <> text+      -- The indicators must fit, they are the actual information.+      pathCsr = displayPathText cursorPos mcursorHP+      trimTgtDesc n t = assert (not (T.null t) && n > 2) $+        if T.length t <= n then t+        else let ellipsis = "..."+                 fitsPlusOne = T.take (n - T.length ellipsis + 1) t+                 fits = if T.last fitsPlusOne == ' '+                        then T.init fitsPlusOne+                        else let lw = T.words fitsPlusOne+                             in T.unwords $ init lw+             in fits <> ellipsis+      cursorText =+        let n = widthTgt - T.length pathCsr - 8+        in (if isJust stgtMode then "cursor>" else "Cursor:")+           <+> trimTgtDesc n cursorDesc+      cursorGap = T.replicate (widthTgt - T.length pathCsr+                                        - T.length cursorText) " "+      cursorStatus = addAttr $ cursorText <> cursorGap <> pathCsr+      minLeaderStatusWidth = 19  -- covers 3-digit HP+  selectedStatus <- drawSelected drawnLevelId+                                 (widthStats - minLeaderStatusWidth)+  leaderStatus <- drawLeaderStatus swaitTimes+                                   (widthStats - length selectedStatus)+  damageStatus <- drawLeaderDamage (widthStats - length leaderStatus+                                               - length selectedStatus)+  nameStatus <- drawPlayerName (widthStats - length leaderStatus+                                           - length selectedStatus+                                           - length damageStatus)+  let statusGap = addAttr $ T.replicate (widthStats - length leaderStatus+                                                    - length selectedStatus+                                                    - length damageStatus+                                                    - length nameStatus) " "+      -- The indicators must fit, they are the actual information.+      pathTgt = displayPathText tgtPos mtargetHP+      targetText =+        let n = widthTgt - T.length pathTgt - 8+        in "Target:" <+> trimTgtDesc n targetDesc+      targetGap = T.replicate (widthTgt - T.length pathTgt+                                        - T.length targetText) " "+      targetStatus = addAttr $ targetText <> targetGap <> pathTgt+      sfBottom =+        [ encodeLine $ arenaStatus ++ cursorStatus+        , encodeLine $ selectedStatus ++ nameStatus ++ statusGap+                       ++ damageStatus ++ leaderStatus+                       ++ targetStatus ]+      fLine y = encodeLine $+        let f l x = let ac = dis $ Point x y in ac : l+        in foldl' f [] [lxsize-1,lxsize-2..0]+      sfLevel =  -- fully evaluated+        let f l y = let !line = fLine y in line : l+        in foldl' f [] [lysize-1,lysize-2..0]+  return $! SingleFrame{..}++inverseVideo :: Color.Attr+inverseVideo = Color.Attr { Color.fg = Color.bg Color.defAttr+                          , Color.bg = Color.fg Color.defAttr }++-- Comfortably accomodates 3-digit level numbers and 25-character+-- level descriptions (currently enforced max).+drawArenaStatus :: Bool -> Level -> Int -> [Color.AttrChar]+drawArenaStatus explored Level{ldepth=AbsDepth ld, ldesc, lseen, lclear} width =+  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)+      seenN = 100 * lseen `div` max 1 lclear+      seenTxt | explored || seenN >= 100 = "all"+              | otherwise = T.justifyLeft 3 ' ' (tshow seenN <> "%")+      lvlN = T.justifyLeft 2 ' ' (tshow ld)+      seenStatus = "[" <> seenTxt <+> "seen] "+  in addAttr $ T.justifyLeft width ' '+             $ T.take 29 (lvlN <+> T.justifyLeft 26 ' ' ldesc) <+> seenStatus++drawLeaderStatus :: MonadClient m => Int -> Int -> m [Color.AttrChar]+drawLeaderStatus waitT width = do+  mleader <- getsClient _sleader+  s <- getState+  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)+      addColor c t = map (Color.AttrChar $ Color.Attr c Color.defBG)+                         (T.unpack t)+      maxLeaderStatusWidth = 23  -- covers 3-digit HP and 2-digit Calm+      (calmHeaderText, hpHeaderText) = if width < maxLeaderStatusWidth+                                       then ("C", "H")+                                       else ("Calm", "HP")+  case mleader of+    Just leader -> do+      activeItems <- activeItemsClient leader+      let (darkL, bracedL, hpDelta, calmDelta,+           ahpS, bhpS, acalmS, bcalmS) =+            let b@Actor{bhp, bcalm} = getActorBody leader s+                amaxHP = sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems+                amaxCalm = sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems+            in ( not (actorInAmbient b s)+               , braced b, bhpDelta b, bcalmDelta b+               , tshow $ max 0 amaxHP, tshow (bhp `divUp` oneM)+               , tshow $ max 0 amaxCalm, tshow (bcalm `divUp` oneM))+          -- This is a valuable feedback for the otherwise hard to observe+          -- '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+          calmAddAttr = checkDelta calmDelta+          darkPick | darkL   = "."+                   | otherwise = ":"+          calmHeader = calmAddAttr $ calmHeaderText <> darkPick+          calmText = bcalmS <>  (if darkL then slashPick else "/") <> acalmS+          bracePick | bracedL   = "}"+                    | otherwise = ":"+          hpAddAttr = checkDelta hpDelta+          hpHeader = hpAddAttr $ hpHeaderText <> bracePick+          hpText = bhpS <> (if bracedL then slashPick else "/") <> ahpS+      return $! calmHeader <> addAttr (T.justifyRight 6 ' ' calmText <> " ")+                <> hpHeader <> addAttr (T.justifyRight 6 ' ' hpText <> " ")+    Nothing -> return $! addAttr $ calmHeaderText <> ": --/-- "+                                   <> hpHeaderText <> ": --/-- "++drawLeaderDamage :: MonadClient m => Int -> m [Color.AttrChar]+drawLeaderDamage width = do+  mleader <- getsClient _sleader+  let addColor t = map (Color.AttrChar $ Color.Attr Color.BrCyan Color.defBG)+                   (T.unpack t)+  stats <- case mleader of+    Just leader -> do+      allAssocs <- fullAssocsClient leader [CEqp, COrgan]+      let activeItems = map snd allAssocs+          damage = case strongestSlotNoFilter Effect.EqpSlotWeapon allAssocs of+            (_, (_, itemFull)) : _->+              let getD :: Effect.Effect a -> Maybe Dice.Dice+                       -> Maybe Dice.Dice+                  getD (Effect.Hurt dice) _ = Just dice+                  getD _ acc = acc+                  mdice = case itemDisco itemFull of+                    Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->+                      foldr getD Nothing jeffects+                    Just ItemDisco{itemKind} ->+                      foldr getD Nothing (ieffects itemKind)+                    Nothing -> Nothing+                  tdice = case mdice of+                    Nothing -> "0"+                    Just dice -> tshow dice+                  bonus = sumSlotNoFilter Effect.EqpSlotAddHurtMelee activeItems+                  unknownBonus = unknownMelee activeItems+                  tbonus = if bonus == 0+                           then if unknownBonus then "+?" else ""+                           else (if bonus > 0 then "+" else "")+                                <> tshow bonus+                                <> if unknownBonus then "%?" else "%"+             in tdice <> tbonus+            [] -> "0"+      return $! damage+    Nothing -> return ""+  return $! if T.null stats || T.length stats >= width then []+            else addColor $ stats <> " "++-- TODO: colour some texts using the faction's colour+drawSelected :: MonadClient m => LevelId -> Int -> m [Color.AttrChar]+drawSelected drawnLevelId width = do+  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+      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 ->+                     Color.defAttr {Color.bg = Color.Blue}+                   _ -> Color.defAttr+                 char = if length ours > maxViewed then '$' else '*'+             in Color.AttrChar sattr char+      viewed = take maxViewed $ sort $ map viewOurs ours+      addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)+      allOurs = filter ((== side) . bfid) $ EM.elems $ sactorD s+      party = if length allOurs <= 1+              then []+              else [star] ++ map snd viewed ++ addAttr " "+  return $! party++drawPlayerName :: MonadClient m => Int -> m [Color.AttrChar]+drawPlayerName width = do+  let addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  let nameN n t =+        let fitWords [] = []+            fitWords l@(_ : rest) = if sum (map T.length l) + length l - 1 > n+                                    then fitWords rest+                                    else l+        in T.unwords $ reverse $ fitWords $ reverse $ T.words t+      ourName = nameN (width - 1) $ playerName $ gplayer fact+  return $! if T.null ourName || T.length ourName >= width+            then []+            else addAttr $ ourName <> " "
+ Game/LambdaHack/Client/UI/Frontend.hs view
@@ -0,0 +1,133 @@+-- | Display game data on the screen and receive user input+-- using one of the available raw frontends and derived operations.+module Game.LambdaHack.Client.UI.Frontend+  ( -- * Connection types.+    FrontReq(..), ChanFrontend(..)+    -- * Re-exported part of the raw frontend+  , frontendName+    -- * A derived operation+  , startupF+  ) where++import Control.Concurrent+import qualified Control.Concurrent.STM as STM+import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.Text.IO as T+import System.IO++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++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]}+      -- ^ show a whole slideshow without interleaving with other clients+  | FrontFinish+      -- ^ exit frontend loop++-- | Connection channel between a frontend and a client. Frontend acts+-- as a server, serving keys, when given frames to display.+data ChanFrontend = ChanFrontend+  { responseF :: !(STM.TQueue K.KM)+  , requestF  :: !(STM.TQueue FrontReq)+  }++startupF :: DebugModeCli+         -> (Maybe (MVar ()) -> (ChanFrontend -> IO ()) -> IO ())+         -> IO ()+startupF dbg cont =+  (if sfrontendNull dbg then nullStartup+   else if sfrontendStd dbg then stdStartup+        else chosenStartup) dbg $ \fs -> do+    cont (fescMVar fs) (loopFrontend fs)+    let debugPrint t = when (sdbgMsgCli dbg) $ do+          T.hPutStrLn stderr t+          hFlush stderr+    debugPrint "Server shuts down"++-- | Display a prompt, wait for any of the specified keys (for any key,+-- if the list is empty). Repeat if an unexpected key received.+promptGetKey :: RawFrontend -> [K.KM] -> SingleFrame -> IO K.KM+promptGetKey fs [] frame = fpromptGetKey fs frame+promptGetKey fs keys frame = do+  km <- fpromptGetKey fs frame+  if km `elem` keys+    then return km+    else promptGetKey fs keys frame++getConfirmGeneric :: RawFrontend -> [K.KM] -> SingleFrame -> IO (Maybe Bool)+getConfirmGeneric fs clearKeys frame = do+  let DebugModeCli{snoMore} = fdebugCli fs+  -- TODO: turn noMore off somehow when faction not under computer control;+  -- perhaps by adding a FrontReq request that turns it off/on?+  if snoMore then do+    fdisplay fs True (Just frame)+    return $ Just True+  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++-- Read UI requests from the client and send them to the frontend,+loopFrontend :: RawFrontend -> ChanFrontend -> IO ()+loopFrontend fs ChanFrontend{..} = loop+ where+  writeKM :: K.KM -> IO ()+  writeKM km = STM.atomically $ STM.writeTQueue responseF km++  loop :: IO ()+  loop = do+    efr <- STM.atomically $ STM.readTQueue requestF+    case efr of+      FrontNormalFrame{..} -> do+        fdisplay fs False (Just frontFrame)+        loop+      FrontRunningFrame{..} -> do+        fdisplay fs True (Just frontFrame)+        loop+      FrontDelay -> do+        fdisplay fs False Nothing+        loop+      FrontKey{..} -> do+        km <- promptGetKey fs frontKM frontFr+        writeKM km+        loop+      FrontSlides{frontSlides = []} -> do+        -- Hack.+        fsyncFrames fs+        writeKM K.spaceKM+        loop+      FrontSlides{..} -> do+        let displayFrs frs srf =+              case frs of+                [] -> assert `failure` "null slides" `twith` frs+                [x] -> do+                  fdisplay fs False (Just x)+                  writeKM K.spaceKM+                x : xs -> do+                  go <- getConfirmGeneric fs frontClear x+                  case go of+                    Nothing -> writeKM K.escKM+                    Just True -> displayFrs xs (x : srf)+                    Just False -> case srf of+                      [] -> displayFrs frs srf+                      y : ys -> displayFrs (y : frs) ys+        displayFrs frontSlides []+        loop+      FrontFinish ->+        return ()+        -- Do not loop again.
+ Game/LambdaHack/Client/UI/Frontend/Chosen.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE CPP #-}+-- | Re-export the operations of the chosen raw frontend+-- (determined at compile time with cabal flags).+module Game.LambdaHack.Client.UI.Frontend.Chosen+  ( RawFrontend(..), chosenStartup, stdStartup, nullStartup+  , frontendName+  ) where++import Control.Concurrent+import qualified Game.LambdaHack.Client.Key as K+import Game.LambdaHack.Client.UI.Animation (SingleFrame (..))+import Game.LambdaHack.Common.ClientOptions++#ifdef VTY+import qualified Game.LambdaHack.Client.UI.Frontend.Vty as Chosen+#elif CURSES+import qualified Game.LambdaHack.Client.UI.Frontend.Curses as Chosen+#else+import qualified Game.LambdaHack.Client.UI.Frontend.Gtk as Chosen+#endif++import qualified Game.LambdaHack.Client.UI.Frontend.Std as Std++-- | The name of the chosen frontend.+frontendName :: String+frontendName = Chosen.frontendName++data RawFrontend = RawFrontend+  { fdisplay      :: Bool -> Maybe SingleFrame -> IO ()+  , fpromptGetKey :: SingleFrame -> IO K.KM+  , fsyncFrames   :: IO ()+  , fescMVar      :: !(Maybe (MVar ()))+  , fdebugCli     :: !DebugModeCli+  }++chosenStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO ()+chosenStartup fdebugCli cont =+  Chosen.startup fdebugCli $ \fs ->+    cont $ RawFrontend+      { fdisplay = Chosen.fdisplay fs+      , fpromptGetKey = Chosen.fpromptGetKey fs+      , fsyncFrames = Chosen.fsyncFrames fs+      , fescMVar = Chosen.sescMVar fs+      , fdebugCli+      }++stdStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO ()+stdStartup fdebugCli cont =+  Std.startup fdebugCli $ \fs ->+    cont $ RawFrontend+      { fdisplay = Std.fdisplay fs+      , fpromptGetKey = Std.fpromptGetKey fs+      , fsyncFrames = Std.fsyncFrames fs+      , fescMVar = Std.sescMVar fs+      , fdebugCli+      }++nullStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO ()+nullStartup fdebugCli cont =+  -- Std used to fork (async) the server thread, to avoid bound thread overhead.+  Std.startup fdebugCli $ \_ ->+    cont $ RawFrontend+      { fdisplay = \_ _ -> return ()+      , fpromptGetKey = \_ -> return K.escKM+      , fsyncFrames = return ()+      , fescMVar = Nothing+      , fdebugCli+      }
+ Game/LambdaHack/Client/UI/Frontend/Curses.hs view
@@ -0,0 +1,167 @@+-- | Text frontend based on HSCurses. This frontend is not fully supported+-- due to the limitations of the curses library (keys, colours, last character+-- of the last line).+module Game.LambdaHack.Client.UI.Frontend.Curses+  ( -- * Session data type for the frontend+    FrontendSession(sescMVar)+    -- * The output and input operations+  , fdisplay, fpromptGetKey, fsyncFrames+    -- * Frontend administration tools+  , frontendName, startup+  ) where++import Control.Concurrent+import Control.Concurrent.Async+import qualified Control.Exception as Ex hiding (handle)+import Control.Exception.Assert.Sugar+import Control.Monad+import Data.Char (chr, ord)+import qualified Data.Map.Strict as M+import qualified UI.HSCurses.Curses as C+import qualified UI.HSCurses.CursesHelper as C++import 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++-- | Session data maintained by the frontend.+data FrontendSession = FrontendSession+  { swin      :: !C.Window  -- ^ the window to draw to+  , sstyles   :: !(M.Map Color.Attr C.CursesStyle)+      -- ^ map from fore/back colour pairs to defined curses styles+  , sescMVar  :: !(Maybe (MVar ()))+  , sdebugCli :: !DebugModeCli  -- ^ client configuration+  }++-- | The name of the frontend.+frontendName :: String+frontendName = "curses"++-- | Starts the main program loop using the frontend input and output.+startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()+startup sdebugCli k = do+  C.start+--  C.keypad C.stdScr False  -- TODO: may help to fix xterm keypad on Ubuntu+  void $ C.cursSet C.CursorInvisible+  let s = [ (Color.Attr{fg, bg}, C.Style (toFColor fg) (toBColor bg))+          | fg <- [minBound..maxBound],+            -- No more color combinations possible: 16*4, 64 is max.+            bg <- Color.legalBG ]+  nr <- C.colorPairs+  when (nr < length s) $+    C.end >> (assert `failure` "terminal has too few color pairs" `twith` nr)+  let (ks, vs) = unzip s+  ws <- C.convertStyles vs+  let swin = C.stdScr+      sstyles = M.fromList (zip ks ws)+  a <- async $ k FrontendSession{sescMVar = Nothing, ..} `Ex.finally` C.end+  wait a++-- | 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+  let SingleFrame{sfLevel} = overlayOverlay rawSF+  -- let defaultStyle = C.defaultCursesStyle+  -- Terminals with white background require this:+  let defaultStyle = sstyles M.! Color.defAttr+  C.erase+  C.setStyle defaultStyle+  -- We need to remove the last character from the status line,+  -- because otherwise it would overflow a standard size xterm window,+  -- due to the curses historical limitations.+  let sfLevelDecoded = map decodeLine sfLevel+      level = init sfLevelDecoded ++ [init $ last sfLevelDecoded]+      nm = zip [0..] $ map (zip [0..]) level+  sequence_ [ C.setStyle (M.findWithDefault defaultStyle acAttr sstyles)+              >> C.mvWAddStr swin (y + 1) x [acChar]+            | (y, line) <- nm, (x, Color.AttrChar{..}) <- line ]+  C.refresh++-- | Input key via the frontend.+nextEvent :: IO K.KM+nextEvent = keyTranslate `fmap` C.getKey C.refresh++fsyncFrames :: FrontendSession -> IO ()+fsyncFrames _ = return ()++-- | Display a prompt, wait for any key.+fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM+fpromptGetKey sess frame = do+  fdisplay sess True $ Just frame+  nextEvent++keyTranslate :: C.Key -> K.KM+keyTranslate e = (\(key, modifier) -> K.KM {..}) $+  case e of+    C.KeyChar '\ESC' -> (K.Esc,     K.NoModifier)+    C.KeyExit        -> (K.Esc,     K.NoModifier)+    C.KeyChar '\n'   -> (K.Return,  K.NoModifier)+    C.KeyChar '\r'   -> (K.Return,  K.NoModifier)+    C.KeyEnter       -> (K.Return,  K.NoModifier)+    C.KeyChar ' '    -> (K.Space,   K.NoModifier)+    C.KeyChar '\t'   -> (K.Tab,     K.NoModifier)+    C.KeyBTab        -> (K.BackTab, K.NoModifier)+    C.KeyBackspace   -> (K.BackSpace, K.NoModifier)+    C.KeyUp          -> (K.Up,      K.NoModifier)+    C.KeyDown        -> (K.Down,    K.NoModifier)+    C.KeyLeft        -> (K.Left,    K.NoModifier)+    C.KeySLeft       -> (K.Left,    K.NoModifier)+    C.KeyRight       -> (K.Right,   K.NoModifier)+    C.KeySRight      -> (K.Right,   K.NoModifier)+    C.KeyHome        -> (K.Home,    K.NoModifier)+    C.KeyEnd         -> (K.End,     K.NoModifier)+    C.KeyPPage       -> (K.PgUp,    K.NoModifier)+    C.KeyNPage       -> (K.PgDn,    K.NoModifier)+    C.KeyBeg         -> (K.Begin,   K.NoModifier)+    C.KeyB2          -> (K.Begin,   K.NoModifier)+    C.KeyClear       -> (K.Begin,   K.NoModifier)+    -- No KP_ keys; see <https://github.com/skogsbaer/hscurses/issues/10>+    -- TODO: try to get the Control modifier for keypad keys from the escape+    -- gibberish and use Control-keypad for KP_ movement.+    C.KeyChar c+      -- This case needs to be considered after Tab, since, apparently,+      -- on some terminals ^i == Tab and Tab is more important for us.+      | ord '\^A' <= ord c && ord c <= ord '\^Z' ->+        -- Alas, only lower-case letters.+        (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control)+        -- Movement keys are more important than leader picking,+        -- so disabling the latter and interpreting the keypad numbers+        -- as movement:+      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)+      | otherwise           -> (K.Char c,            K.NoModifier)+    _                       -> (K.Unknown (tshow e), K.NoModifier)++toFColor :: Color.Color -> C.ForegroundColor+toFColor Color.Black     = C.BlackF+toFColor Color.Red       = C.DarkRedF+toFColor Color.Green     = C.DarkGreenF+toFColor Color.Brown     = C.BrownF+toFColor Color.Blue      = C.DarkBlueF+toFColor Color.Magenta   = C.PurpleF+toFColor Color.Cyan      = C.DarkCyanF+toFColor Color.White     = C.WhiteF+toFColor Color.BrBlack   = C.GreyF+toFColor Color.BrRed     = C.RedF+toFColor Color.BrGreen   = C.GreenF+toFColor Color.BrYellow  = C.YellowF+toFColor Color.BrBlue    = C.BlueF+toFColor Color.BrMagenta = C.MagentaF+toFColor Color.BrCyan    = C.CyanF+toFColor Color.BrWhite   = C.BrightWhiteF++toBColor :: Color.Color -> C.BackgroundColor+toBColor Color.Black     = C.BlackB+toBColor Color.Red       = C.DarkRedB+toBColor Color.Green     = C.DarkGreenB+toBColor Color.Brown     = C.BrownB+toBColor Color.Blue      = C.DarkBlueB+toBColor Color.Magenta   = C.PurpleB+toBColor Color.Cyan      = C.DarkCyanB+toBColor Color.White     = C.WhiteB+toBColor _               = C.BlackB  -- a limitation of curses
+ Game/LambdaHack/Client/UI/Frontend/Gtk.hs view
@@ -0,0 +1,464 @@+-- | Text frontend based on Gtk.+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Game.LambdaHack.Client.UI.Frontend.Gtk+  ( -- * Session data type for the frontend+    FrontendSession(sescMVar)+    -- * The output and input operations+  , fdisplay, fpromptGetKey, fsyncFrames+    -- * Frontend administration tools+  , frontendName, startup+  ) where++import Control.Concurrent+import Control.Concurrent.Async+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+import Data.IORef+import Data.List+import qualified Data.Map.Strict as M+import Data.Maybe+import Graphics.UI.Gtk hiding (Point)+import System.Time++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.LQueue++data FrameState =+    FPushed  -- frames stored in a queue, to be drawn in equal time intervals+      { fpushed :: !(LQueue (Maybe GtkFrame))  -- ^ screen output channel+      , fshown  :: !GtkFrame                   -- ^ last full frame shown+      }+  | FNone  -- no frames stored++-- | Session data maintained by the frontend.+data FrontendSession = FrontendSession+  { sview       :: !TextView                    -- ^ the widget to draw to+  , stags       :: !(M.Map Color.Attr TextTag)  -- ^ text color tags for fg/bg+  , schanKey    :: !(Chan K.KM)                 -- ^ channel for keyboard input+  , sframeState :: !(MVar FrameState)+      -- ^ State of the frame finite machine. This mvar is locked+      -- for a short time only, because it's needed, among others,+      -- to display frames, which is done by a single polling thread,+      -- in real time.+  , slastFull   :: !(MVar (GtkFrame, Bool))+      -- ^ Most recent full (not empty, not repeated) frame received+      -- and if any empty frame followed it. This mvar is locked+      -- for longer intervals to ensure that threads (possibly many)+      -- add frames in an orderly manner. This is not done in real time,+      -- though sometimes the frame display subsystem has to poll+      -- for a frame, in which case the locking interval becomes meaningful.+  , sescMVar    :: !(Maybe (MVar ()))+  , sdebugCli   :: !DebugModeCli  -- ^ client configuration+  }++data GtkFrame = GtkFrame+  { gfChar :: !BS.ByteString+  , gfAttr :: ![[TextTag]]+  }+  deriving Eq++dummyFrame :: GtkFrame+dummyFrame = GtkFrame BS.empty []++-- | Perform an operation on the frame queue.+onQueue :: (LQueue (Maybe GtkFrame) -> LQueue (Maybe GtkFrame))+        -> FrontendSession -> IO ()+onQueue f FrontendSession{sframeState} = do+  fs <- takeMVar sframeState+  case fs of+    FPushed{..} ->+      putMVar sframeState FPushed{fpushed = f fpushed, ..}+    _ ->+      putMVar sframeState fs++-- | The name of the frontend.+frontendName :: String+frontendName = "gtk"++-- | Starts GTK. The other threads have to be spawned+-- after gtk is initialized, because they call @postGUIAsync@,+-- and need @sview@ and @stags@. Because of Windows, GTK needs to be+-- on a bound thread, so we can't avoid the communication overhead+-- of bound threads, so there's no point spawning a separate thread for GTK.+startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()+startup = runGtk++-- | Sets up and starts the main GTK loop providing input and output.+runGtk :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()+runGtk sdebugCli@DebugModeCli{sfont} cont = do+  -- Init GUI.+  unsafeInitGUIForThreadedRTS+  -- Text attributes.+  ttt <- textTagTableNew+  stags <- fmap M.fromList $+             mapM (\ ak -> do+                      tt <- textTagNew Nothing+                      textTagTableAdd ttt tt+                      doAttr tt ak+                      return (ak, tt))+               [ Color.Attr{fg, bg}+               | fg <- [minBound..maxBound], bg <- Color.legalBG ]+  -- Text buffer.+  tb <- textBufferNew (Just ttt)+  -- Create text view. TODO: use GtkLayout or DrawingArea instead of TextView?+  sview <- textViewNewWithBuffer tb+  textViewSetEditable sview False+  textViewSetCursorVisible sview False+  -- Set up the channel for keyboard input.+  schanKey <- newChan+  -- Set up the frame state.+  let frameState = FNone+  -- Create the session record.+  sframeState <- newMVar frameState+  slastFull <- newMVar (dummyFrame, False)+  escMVar <- newEmptyMVar+  let sess = FrontendSession{sescMVar = Just escMVar, ..}+  -- Fork the game logic thread. When logic ends, game exits.+  -- TODO: is postGUISync needed here?+  aCont <- async $ cont sess `Ex.finally` postGUISync mainQuit+  link aCont+  -- Fork the thread that periodically draws a frame from a queue, if any.+  aPoll <- async $ pollFramesAct sess `Ex.finally` postGUISync mainQuit+  link aPoll+  -- Fill the keyboard channel.+  sview `on` keyPressEvent $ do+    n <- eventKeyName+    mods <- eventModifier+    let !key = K.keyTranslate n+        !modifier = modifierTranslate mods+    liftIO $ do+      unless (deadKey n) $ do+        -- If ESC, also mark it specially.+        when (key == K.Esc) $+          void $ tryPutMVar escMVar ()+        -- Store the key in the channel.+        writeChan schanKey K.KM{key, modifier}+      return True+  -- Set the font specified in config, if any.+  f <- fontDescriptionFromString $ fromMaybe "" sfont+  widgetModifyFont sview (Just f)+  -- Prepare font chooser dialog.+  currentfont <- newIORef f+  sview `on` buttonPressEvent $ do+    but <- eventButton+    liftIO $ case but of+      RightButton -> do+        fsd <- fontSelectionDialogNew "Choose font"+        cf  <- readIORef currentfont  -- TODO: "Terminus,Monospace" fails+        fds <- fontDescriptionToString cf+        fontSelectionDialogSetFontName fsd fds+        fontSelectionDialogSetPreviewText fsd "eee...@.##+##"+        resp <- dialogRun fsd+        when (resp == ResponseOk) $ do+          fn <- fontSelectionDialogGetFontName fsd+          case fn of+            Just fn' -> do+              fd <- fontDescriptionFromString fn'+              writeIORef currentfont fd+              widgetModifyFont sview (Just fd)+            Nothing  -> return ()+        widgetDestroy fsd+        return True+      _ -> return False+  -- Modify default colours.+  let black = Color minBound minBound minBound  -- Color.defBG == Color.Black+      white = Color 0xC500 0xBC00 0xB800        -- Color.defFG == Color.White+  widgetModifyBase sview StateNormal black+  widgetModifyText sview StateNormal white+  -- Set up the main window.+  w <- windowNew+  containerAdd w sview+  onDestroy w mainQuit+  widgetShowAll w+  mainGUI++-- | Output to the screen via the frontend.+output :: FrontendSession  -- ^ frontend session data+       -> GtkFrame         -- ^ the screen frame to draw+       -> IO ()+output FrontendSession{sview, stags} GtkFrame{..} = do  -- new frame+  tb <- textViewGetBuffer sview+  let attrs = zip [0..] gfAttr+      defAttr = stags M.! Color.defAttr+  textBufferSetByteString tb gfChar+  mapM_ (setTo tb defAttr 0) attrs++setTo :: TextBuffer -> TextTag -> Int -> (Int, [TextTag]) -> IO ()+setTo _ _ _ (_,  []) = return ()+setTo tb defAttr lx (ly, attr:attrs) = do+  ib <- textBufferGetIterAtLineOffset tb ly lx+  ie <- textIterCopy ib+  let setIter :: TextTag -> Int -> [TextTag] -> IO ()+      setIter previous repetitions [] = do+        textIterForwardChars ie repetitions+        when (previous /= defAttr) $+          textBufferApplyTag tb previous ib ie+      setIter previous repetitions (a:as)+        | a == previous =+            setIter a (repetitions + 1) as+        | otherwise = do+            textIterForwardChars ie repetitions+            when (previous /= defAttr) $+              textBufferApplyTag tb previous ib ie+            textIterForwardChars ib repetitions+            setIter a 1 as+  setIter attr 1 attrs++-- | Maximal polls per second.+maxPolls :: Int -> Int+maxPolls maxFps = max 120 (2 * maxFps)++picoInMicro :: Int+picoInMicro = 1000000++-- | Add a given number of microseconds to time.+addTime :: ClockTime -> Int -> ClockTime+addTime (TOD s p) mus = TOD s (p + fromIntegral (mus * picoInMicro))++-- | The difference between the first and the second time, in microseconds.+diffTime :: ClockTime -> ClockTime -> Int+diffTime (TOD s1 p1) (TOD s2 p2) =+  fromIntegral (s1 - s2) * picoInMicro ++  fromIntegral (p1 - p2) `div` picoInMicro++microInSec :: Int+microInSec = 1000000++defaultMaxFps :: Int+defaultMaxFps = 15++-- | Poll the frame queue often and draw frames at fixed intervals.+pollFramesWait :: FrontendSession -> ClockTime -> IO ()+pollFramesWait sess@FrontendSession{sdebugCli=DebugModeCli{smaxFps}}+               setTime = do+  -- Check if the time is up.+  let maxFps = fromMaybe defaultMaxFps smaxFps+  curTime <- getClockTime+  let diffSetCur = diffTime setTime curTime+  if diffSetCur > microInSec `div` maxPolls maxFps+    then do+      -- Delay half of the time difference.+      threadDelay $ diffTime curTime setTime `div` 2+      pollFramesWait sess setTime+    else+      -- Don't delay, because time is up!+      pollFramesAct sess++-- | Poll the frame queue often and draw frames at fixed intervals.+pollFramesAct :: FrontendSession -> IO ()+pollFramesAct sess@FrontendSession{sframeState, sdebugCli=DebugModeCli{..}} = do+  -- Time is up, check if we actually wait for anyting.+  let maxFps = fromMaybe defaultMaxFps smaxFps+  fs <- takeMVar sframeState+  case fs of+    FPushed{..} ->+      case tryReadLQueue fpushed of+        Just (Just frame, queue) -> do+          -- The frame has arrived so send it for drawing and update delay.+          putMVar sframeState FPushed{fpushed = queue, fshown = frame}+          -- Count the time spent outputting towards the total frame time.+          curTime <- getClockTime+          -- Wait until the frame is drawn.+          postGUISync $ output sess frame+          -- Regardless of how much time drawing took, wait at least+          -- half of the normal delay time. This can distort the large-scale+          -- frame rhythm, but makes sure this frame can at all be seen.+          -- If the main GTK thread doesn't lag, large-scale rhythm will be OK.+          -- TODO: anyway, it's GC that causes visible snags, most probably.+          threadDelay $ microInSec `div` (maxFps * 2)+          pollFramesWait sess $ addTime curTime $ microInSec `div` maxFps+        Just (Nothing, queue) -> do+          -- Delay requested via an empty frame.+          putMVar sframeState FPushed{fpushed = queue, ..}+          unless snoDelay $+            -- There is no problem if the delay is a bit delayed.+            threadDelay $ microInSec `div` maxFps+          pollFramesAct sess+        Nothing -> do+          -- The queue is empty, the game logic thread lags.+          putMVar sframeState fs+          -- Time is up, the game thread is going to send a frame,+          -- (otherwise it would change the state), so poll often.+          threadDelay $ microInSec `div` maxPolls maxFps+          pollFramesAct sess+    _ -> 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+      -- in creating frames in case one of the further frames is slow+      -- to generate and would normally cause a jerky delay in drawing.+      threadDelay $ microInSec `div` (maxFps * 2)+      pollFramesAct sess++-- | 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+  let FrontendSession{sframeState, slastFull} = sess+  -- Full evaluation is done outside the mvar locks.+  let !frame = case rawFrame of+        Nothing -> Nothing+        Just fr -> Just $! evalFrame sess fr+  -- Lock frame addition.+  (lastFrame, anyFollowed) <- takeMVar slastFull+  -- Comparison of frames is done outside the frame queue mvar lock.+  let nextFrame = if frame == Just lastFrame+                  then Nothing  -- no sense repeating+                  else frame+  -- Lock frame queue.+  fs <- takeMVar sframeState+  case fs of+    FPushed{..} ->+      putMVar sframeState+      $ if isNothing nextFrame && anyFollowed+        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+      -- 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{..}+  case nextFrame of+    Nothing -> putMVar slastFull (lastFrame, True)+    Just f  -> putMVar slastFull (f, noDelay)++evalFrame :: FrontendSession -> SingleFrame -> GtkFrame+evalFrame FrontendSession{stags} rawSF =+  let SingleFrame{sfLevel} = overlayOverlay rawSF+      sfLevelDecoded = map decodeLine sfLevel+      levelChar = unlines $ map (map Color.acChar) sfLevelDecoded+      gfChar = BS.pack $ init levelChar+      -- Strict version of @map (map ((stags M.!) . fst)) sfLevelDecoded@.+      gfAttr  = reverse $ foldl' ff [] sfLevelDecoded+      ff ll l = reverse (foldl' f [] l) : ll+      f l ac  = let !tag = stags M.! Color.acAttr ac in tag : l+  in GtkFrame{..}++-- | Trim current frame queue and display the most recent frame, if any.+trimFrameState :: FrontendSession -> IO ()+trimFrameState sess@FrontendSession{sframeState} = do+  -- Take the lock to wipe out the frame queue, unless it's empty already.+  fs <- takeMVar sframeState+  case fs of+    FPushed{..} ->+      -- Remove all but the last element of the frame queue.+      -- The kept (and displayed) last element ensures that+      -- @slastFull@ is not invalidated.+      case lastLQueue fpushed of+        Just frame -> do+          -- Comparison is done inside the mvar lock, this time, but it's OK,+          -- since we wipe out the queue anyway, not draw it concurrently.+          let lastFrame = fshown+              nextFrame = if frame == lastFrame+                          then Nothing  -- no sense repeating+                          else Just frame+          -- Draw the last frame ASAP.+          maybe skip (postGUIAsync . output sess) nextFrame+        Nothing -> return ()+    FNone -> return ()+  -- Wipe out the frame queue. Release the lock.+  putMVar sframeState FNone++-- | 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++-- Display all queued frames, synchronously.+displayAllFramesSync :: FrontendSession -> FrameState -> IO ()+displayAllFramesSync sess@FrontendSession{sdebugCli=DebugModeCli{..}} fs = do+  let maxFps = fromMaybe defaultMaxFps smaxFps+  case fs of+    FPushed{..} ->+      case tryReadLQueue fpushed of+        Just (Just frame, queue) -> do+          -- Display synchronously.+          postGUISync $ output sess frame+          threadDelay $ microInSec `div` maxFps+          displayAllFramesSync sess FPushed{fpushed = queue, fshown = frame}+        Just (Nothing, queue) -> do+          -- Delay requested via an empty frame.+          unless snoDelay $+            threadDelay $ microInSec `div` maxFps+          displayAllFramesSync sess FPushed{fpushed = queue, ..}+        Nothing ->+          -- The queue is empty.+          return ()+    _ ->+      -- Not in Push state to start with.+      return ()++fsyncFrames :: FrontendSession -> IO ()+fsyncFrames sess@FrontendSession{sframeState} = do+  fs <- takeMVar sframeState+  displayAllFramesSync sess fs+  putMVar sframeState FNone++-- | Display a prompt, wait for any key.+-- Starts in Push mode, ends in Push or None mode.+-- Syncs with the drawing threads by showing the last or all queued frames.+fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM+fpromptGetKey sess@FrontendSession{..}+              frame = do+  pushFrame sess True True $ Just frame+  km <- readChan schanKey+  case km of+    K.KM{key=K.Space} ->+      -- Drop frames up to the first empty frame.+      -- Keep the last non-empty frame, if any.+      -- Pressing SPACE repeatedly can be used to step+      -- through intermediate stages of an animation,+      -- whereas any other key skips the whole animation outright.+      onQueue dropStartLQueue sess+    _ ->+      -- Show the last non-empty frame and empty the queue.+      trimFrameState sess+  return km++-- | Tells a dead key.+deadKey :: String -> Bool+deadKey x = case x of+  "Shift_L"          -> True+  "Shift_R"          -> True+  "Control_L"        -> True+  "Control_R"        -> True+  "Super_L"          -> True+  "Super_R"          -> True+  "Menu"             -> True+  "Alt_L"            -> True+  "Alt_R"            -> True+  "ISO_Level2_Shift" -> True+  "ISO_Level3_Shift" -> True+  "ISO_Level2_Latch" -> True+  "ISO_Level3_Latch" -> True+  "Num_Lock"         -> True+  "Caps_Lock"        -> True+  _                  -> False++-- | Translates modifiers to our own encoding.+modifierTranslate :: [Modifier] -> K.Modifier+modifierTranslate mods =+  if Control `elem` mods then K.Control else K.NoModifier++doAttr :: TextTag -> Color.Attr -> IO ()+doAttr tt attr@Color.Attr{fg, bg}+  | attr == Color.defAttr = return ()+  | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg]+  | bg == Color.defBG = set tt [textTagForeground := Color.colorToRGB fg]+  | otherwise         = set tt [textTagForeground := Color.colorToRGB fg,+                                textTagBackground := Color.colorToRGB bg]
+ Game/LambdaHack/Client/UI/Frontend/Std.hs view
@@ -0,0 +1,84 @@+-- | Text frontend based on stdin/stdout, intended for bots.+module Game.LambdaHack.Client.UI.Frontend.Std+  ( -- * Session data type for the frontend+    FrontendSession(sescMVar)+    -- * The output and input operations+  , fdisplay, fpromptGetKey, fsyncFrames+    -- * Frontend administration tools+  , frontendName, startup+  ) where++import Control.Concurrent+import Control.Concurrent.Async+import qualified Control.Exception as Ex hiding (handle)+import qualified Data.ByteString.Char8 as BS+import Data.Char (chr, ord)+import qualified System.IO as SIO++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++-- | No session data needs to be maintained by this frontend.+data FrontendSession = FrontendSession+  { sdebugCli :: !DebugModeCli  -- ^ client configuration+  , sescMVar  :: !(Maybe (MVar ()))+  }++-- | The name of the frontend.+frontendName :: String+frontendName = "std"++-- | Starts the main program loop using the frontend input and output.+startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()+startup sdebugCli k = do+  a <- async $ k FrontendSession{sescMVar = Nothing, ..}+               `Ex.finally` (SIO.hFlush SIO.stdout >> SIO.hFlush SIO.stderr)+  wait a++-- | 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) =+  let SingleFrame{sfLevel} = overlayOverlay rawSF+      bs = map (BS.pack . map Color.acChar . decodeLine) sfLevel ++ [BS.empty]+  in mapM_ BS.putStrLn bs++-- | Input key via the frontend.+nextEvent :: IO K.KM+nextEvent = do+  l <- BS.hGetLine SIO.stdin+  let c = case BS.uncons l of+        Nothing -> '\n'  -- empty line counts as RET+        Just (hd, _) -> hd+  return $! keyTranslate c++fsyncFrames :: FrontendSession -> IO ()+fsyncFrames _ = return ()++-- | Display a prompt, wait for any key.+fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM+fpromptGetKey sess frame = do+  fdisplay sess True $ Just frame+  nextEvent++keyTranslate :: Char -> K.KM+keyTranslate e = (\(key, modifier) -> K.KM {..}) $+  case e of+    '\ESC' -> (K.Esc,     K.NoModifier)+    '\n'   -> (K.Return,  K.NoModifier)+    '\r'   -> (K.Return,  K.NoModifier)+    ' '    -> (K.Space,   K.NoModifier)+    '\t'   -> (K.Tab,     K.NoModifier)+    c | ord '\^A' <= ord c && ord c <= ord '\^Z' ->+        -- Alas, only lower-case letters.+        (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control)+        -- Movement keys are more important than leader picking,+        -- so disabling the latter and interpreting the keypad numbers+        -- as movement:+      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)+      | otherwise           -> (K.Char c,            K.NoModifier)
+ Game/LambdaHack/Client/UI/Frontend/Vty.hs view
@@ -0,0 +1,144 @@+-- | Text frontend based on Vty.+module Game.LambdaHack.Client.UI.Frontend.Vty+  ( -- * Session data type for the frontend+    FrontendSession(sescMVar)+    -- * The output and input operations+  , fdisplay, fpromptGetKey, fsyncFrames+    -- * Frontend administration tools+  , frontendName, startup+  ) where++import Control.Concurrent+import Control.Concurrent.Async+import qualified Control.Exception as Ex hiding (handle)+import Graphics.Vty+import qualified Graphics.Vty as Vty++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++-- | Session data maintained by the frontend.+data FrontendSession = FrontendSession+  { svty      :: !Vty  -- internal vty session+  , sescMVar  :: !(Maybe (MVar ()))+  , sdebugCli :: !DebugModeCli  -- ^ client configuration+      -- ^ Configuration of the frontend session.+  }++-- | The name of the frontend.+frontendName :: String+frontendName = "vty"++-- | Starts the main program loop using the frontend input and output.+startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()+startup sdebugCli k = do+  svty <- mkVty+  -- TODO: implement sescMVar, when we switch to a new vty that has+  -- a separate key listener thread or something. Avoid polling.+  a <- async $ k FrontendSession{sescMVar = Nothing, ..}+               `Ex.finally` Vty.shutdown svty+  wait a++-- | 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) =+  let SingleFrame{sfLevel} = overlayOverlay rawSF+      img = (foldr (<->) empty_image+             . map (foldr (<|>) empty_image+                      . map (\ Color.AttrChar{..} ->+                                char (setAttr acAttr) acChar)))+            $ map decodeLine sfLevel+      pic = pic_for_image img+  in update svty pic++-- | Input key via the frontend.+nextEvent :: FrontendSession -> IO K.KM+nextEvent sess@FrontendSession{svty} = do+  e <- next_event svty+  case e of+    EvKey n mods -> do+      let key = keyTranslate n+          modifier = modifierTranslate mods+      return $! K.KM {key, modifier}+    _ -> nextEvent sess++fsyncFrames :: FrontendSession -> IO ()+fsyncFrames _ = return ()++-- | Display a prompt, wait for any key.+fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM+fpromptGetKey sess frame = do+  fdisplay sess True $ Just frame+  nextEvent sess++-- TODO: Ctrl-Home and Ctrl-End are the same as Home and End on some terminals+-- so we should probably go back to using 0-9 (and Shift) for movement+-- but let's wait until vty 5.0 is out and see if it helps.+keyTranslate :: Key -> K.Key+keyTranslate n =+  case n of+    KEsc          -> K.Esc+    KEnter        -> K.Return+    (KASCII ' ')  -> K.Space+    (KASCII '\t') -> K.Tab+    KBackTab      -> K.BackTab+    KBS           -> K.BackSpace+    KUp           -> K.Up+    KDown         -> K.Down+    KLeft         -> K.Left+    KRight        -> K.Right+    KHome         -> K.Home+    KEnd          -> K.End+    KPageUp       -> K.PgUp+    KPageDown     -> K.PgDn+    KBegin        -> K.Begin+    KNP5          -> K.Begin+    (KASCII c)    -> K.Char c+    _             -> K.Unknown (tshow n)++-- | Translates modifiers to our own encoding.+modifierTranslate :: [Modifier] -> K.Modifier+modifierTranslate mods =+  if MCtrl `elem` mods then K.Control else K.NoModifier++-- TODO: with vty 5.0 check if bold is still needed.+-- A hack to get bright colors via the bold attribute. Depending on terminal+-- settings this is needed or not and the characters really get bold or not.+-- HSCurses does this by default, but in Vty you have to request the hack.+hack :: Color.Color -> Attr -> Attr+hack c a = if Color.isBright c then with_style a bold else a++setAttr :: Color.Attr -> Attr+setAttr Color.Attr{fg, bg} =+-- This optimization breaks display for white background terminals:+--  if (fg, bg) == Color.defAttr+--  then def_attr+--  else+  hack fg $ hack bg $+    def_attr { attr_fore_color = SetTo (aToc fg)+             , attr_back_color = SetTo (aToc bg) }++aToc :: Color.Color -> Color+aToc Color.Black     = black+aToc Color.Red       = red+aToc Color.Green     = green+aToc Color.Brown     = yellow+aToc Color.Blue      = blue+aToc Color.Magenta   = magenta+aToc Color.Cyan      = cyan+aToc Color.White     = white+aToc Color.BrBlack   = bright_black+aToc Color.BrRed     = bright_red+aToc Color.BrGreen   = bright_green+aToc Color.BrYellow  = bright_yellow+aToc Color.BrBlue    = bright_blue+aToc Color.BrMagenta = bright_magenta+aToc Color.BrCyan    = bright_cyan+aToc Color.BrWhite   = bright_white
+ Game/LambdaHack/Client/UI/HandleHumanClient.hs view
@@ -0,0 +1,86 @@+-- | Semantics of human player commands.+module Game.LambdaHack.Client.UI.HandleHumanClient+  ( cmdHumanSem+  ) where++import Control.Applicative+import Data.Monoid++import Game.LambdaHack.Client.UI.HandleHumanGlobalClient+import Game.LambdaHack.Client.UI.HandleHumanLocalClient+import Game.LambdaHack.Client.UI.HumanCmd+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.MsgClient+import Game.LambdaHack.Common.Request++-- | The semantics of human player commands in terms of the @Action@ monad.+-- Decides if the action takes time and what action to perform.+-- Some time cosuming commands are enabled in targeting mode, but cannot be+-- 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+  if noRemoteHumanCmd cmd then do+    -- If in targeting mode, check if the current level is the same+    -- as player level and refuse performing the action otherwise.+    arena <- getArenaUI+    lidV <- viewedLevel+    if (arena /= lidV) then+      failWith $ "command disabled on a remote level, press ESC to switch back"+    else cmdAction cmd+  else cmdAction cmd++-- | Compute the basic action for a command and mark whether it takes time.+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+  Wait -> Right <$> fmap ReqUITimed waitHuman+  MoveItem cLegalRaw toCStore verbRaw _ auto ->+    fmap ReqUITimed <$> moveItemHuman cLegalRaw toCStore verbRaw auto+  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++  GameRestart t -> gameRestartHuman t+  GameExit -> gameExitHuman+  GameSave -> fmap Right gameSaveHuman+  Automate -> automateHuman++  -- Local.+  GameDifficultyCycle -> addNoSlides gameDifficultyCycle+  PickLeader k -> Left <$> pickLeaderHuman k+  MemberCycle -> Left <$> memberCycleHuman+  MemberBack -> Left <$> memberBackHuman+  DescribeItem cstore -> Left <$> describeItemHuman cstore+  AllOwned -> Left <$> allOwnedHuman+  SelectActor -> Left <$> selectActorHuman+  SelectNone -> addNoSlides selectNoneHuman+  Clear -> addNoSlides clearHuman+  Repeat n -> addNoSlides $ repeatHuman n+  Record -> Left <$> recordHuman+  History -> Left <$> historyHuman+  MarkVision -> addNoSlides markVisionHuman+  MarkSmell -> addNoSlides markSmellHuman+  MarkSuspect -> addNoSlides markSuspectHuman+  Help -> Left <$> helpHuman+  MainMenu -> Left <$> mainMenuHuman+  Macro _ kms -> addNoSlides $ macroHuman kms++  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+  Cancel -> Left <$> cancelHuman mainMenuHuman+  Accept -> Left <$> acceptHuman helpHuman++addNoSlides :: Monad m => m () -> m (SlideOrCmd RequestUI)+addNoSlides cmdCli = cmdCli >> return (Left mempty)
+ Game/LambdaHack/Client/UI/HandleHumanGlobalClient.hs view
@@ -0,0 +1,576 @@+{-# LANGUAGE DataKinds #-}+-- | Semantics of 'Command.Cmd' client commands that return server commands.+-- A couple of them do not take time, the rest does.+-- TODO: document+module Game.LambdaHack.Client.UI.HandleHumanGlobalClient+  ( -- * Commands that usually take time+    moveRunHuman, waitHuman, moveItemHuman+  , projectHuman, applyHuman, alterDirHuman, triggerTileHuman+  , stepToTargetHuman+    -- * Commands that never take time+  , gameRestartHuman, gameExitHuman, gameSaveHuman, automateHuman+  ) where++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 Data.Monoid+import Data.Text (Text)+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Client.BfsClient+import Game.LambdaHack.Client.CommonClient+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.HandleHumanLocalClient+import Game.LambdaHack.Client.UI.HumanCmd (Trigger (..))+import Game.LambdaHack.Client.UI.InventoryClient+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.MsgClient+import Game.LambdaHack.Client.UI.RunClient+import Game.LambdaHack.Client.UI.WidgetClient+import Game.LambdaHack.Common.Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.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.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.TileKind++-- * Move and Run++moveRunHuman :: MonadClientUI m+             => Bool -> Vector -> m (SlideOrCmd RequestAnyAbility)+moveRunHuman run dir = do+  tgtMode <- getsClient stgtMode+  if isJust tgtMode then+    fmap Left $ moveCursorHuman dir (if run then 10 else 1)+  else do+    arena <- getArenaUI+    leader <- getLeaderUI+    sb <- getsState $ getActorBody leader+    fact <- getsState $ (EM.! bfid sb) . sfactionD+    let tpos = bpos sb `shift` dir+    -- We start by checking actors at the the target position,+    -- which gives a partial information (actors can be invisible),+    -- as opposed to accessibility (and items) which are always accurate+    -- (tiles can't be invisible).+    tgts <- getsState $ posToActors tpos arena+    case tgts of+      [] -> do  -- move or search or alter+        -- Start running in the given direction. The first turn of running+        -- succeeds much more often than subsequent turns, because we ignore+        -- most of the disturbances, since the player is mostly aware of them+        -- and still explicitly requests a run, knowing how it behaves.+        runStopOrCmd <- moveRunAid leader dir+        case runStopOrCmd of+          Left stopMsg -> failWith stopMsg+          Right runCmd -> do+            cops <- getsState scops+            sel <- getsClient sselected+            let runMembers = if isAllMoveFact cops fact+                             then [leader]  -- TODO: warn?+                             else ES.toList (ES.delete leader sel) ++ [leader]+                runParams = RunParams { runLeader = leader+                                      , runMembers+                                      , runDist = 0+                                      , runStopMsg = Nothing+                                      , runInitDir = Just dir }+            when run $ modifyClient $ \cli -> cli {srunning = Just runParams}+            return $ Right runCmd+        -- When running, the invisible actor is hit (not displaced!),+        -- so that running in the presence of roving invisible+        -- actors is equivalent to moving (with visible actors+        -- this is not a problem, since runnning stops early enough).+        -- TODO: stop running at invisible actor+      [((target, _), _)] | run ->+        -- Displacing requires accessibility, but it's checked later on.+        fmap RequestAnyAbility <$> displaceAid target+      _ : _ : _ | run -> do+        assert (all (bproj . snd . fst) tgts) skip+        failSer DisplaceProjectiles+      ((target, tb), _) : _ -> do+        -- No problem if there are many projectiles at the spot. We just+        -- attack the first one.+        -- We always see actors from our own faction.+        if bfid tb == bfid sb && not (bproj tb) then do+          cops <- getsState scops+          if isAllMoveFact cops fact then failWith msgCannotChangeLeader+          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+            return $ Left mempty+        else+          -- Attacking does not require full access, adjacency is enough.+          fmap RequestAnyAbility <$> meleeAid target++-- | Actor atttacks an enemy actor or his own projectile.+meleeAid :: MonadClientUI m+         => ActorId -> m (SlideOrCmd (RequestTimed AbMelee))+meleeAid target = do+  leader <- getLeaderUI+  sb <- getsState $ getActorBody leader+  tb <- getsState $ getActorBody target+  sfact <- getsState $ (EM.! bfid sb) . sfactionD+  mel <- pickWeaponClient leader target+  case mel of+    [] -> failWith "nothing to melee with"+    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+              | otherwise = do+                go2 <- displayYesNo ColorBW+                         "This attack will start a war. Are you sure?"+                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+  -- on a failed altering.++-- | Actor swaps position with another.+displaceAid :: MonadClientUI m+            => ActorId -> m (SlideOrCmd (RequestTimed AbDisplace))+displaceAid target = do+  cops <- getsState scops+  leader <- getLeaderUI+  sb <- getsState $ getActorBody leader+  tb <- getsState $ getActorBody target+  tfact <- getsState $ (EM.! bfid tb) . sfactionD+  activeItems <- activeItemsClient target+  disp <- getsState $ dispEnemy leader target activeItems+  let spos = bpos sb+      tpos = bpos tb+      adj = checkAdjacent sb tb+      atWar = isAtWar tfact (bfid sb)+  if not adj then failSer DisplaceDistant+  else if not (bproj tb) && atWar+          && actorDying tb then failSer DisplaceDying+  else if not (bproj tb) && atWar+          && braced tb then failSer DisplaceBraced+  else if not disp && atWar then failSer DisplaceSupported+  else do+    let lid = blid sb+    lvl <- getLevel lid+    -- Displacing requires full access.+    if accessible cops lvl spos tpos then do+      tgts <- getsState $ posToActors tpos lid+      case tgts of+        [] -> assert `failure` (leader, sb, target, tb)+        [_] -> do+          return $ Right $ ReqDisplace target+        _ -> failSer DisplaceProjectiles+    else failSer DisplaceAccess++-- * Wait++-- | Leader waits a turn (and blocks, etc.).+waitHuman :: MonadClientUI m => m (RequestTimed AbWait)+waitHuman = do+  modifyClient $ \cli -> cli {swaitTimes = abs (swaitTimes cli) + 1}+  return ReqWait++-- * MoveItem++moveItemHuman :: MonadClientUI m+              => [CStore] -> CStore -> Text -> Bool+              -> m (SlideOrCmd (RequestTimed AbMoveItem))+moveItemHuman cLegalRaw destCStore verbRaw auto = do+  assert (destCStore `notElem` cLegalRaw) skip+  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+      verb = MU.Text verbRaw+  ggi <- if auto+         then getAnyItem verb cLegalRaw cLegal False False+         else getAnyItem verb cLegalRaw cLegal True True+  case ggi of+    Right ((iid, itemFull), CActor _ fromCStore) -> do+      let k = itemK itemFull+          msgAndSer toCStore = do+            subject <- partAidLeader leader+            msgAdd $ makeSentence+              [ MU.SubjectVerbSg subject verb, partItemWs k toCStore itemFull ]+            return $ Right $ ReqMoveItem iid k fromCStore toCStore+      if fromCStore == CGround+      then case destCStore of+        CEqp | goesIntoInv (itemBase itemFull) -> do+          updateItemSlot (Just leader) iid  -- slot not yet assigned+          msgAndSer CInv+        CEqp | eqpOverfull b k -> do+          msgAdd $ "Warning:" <+> showReqFailure EqpOverfull+          updateItemSlot (Just leader) iid  -- slot not yet assigned+          msgAndSer CInv+        _ -> msgAndSer destCStore+      else case destCStore of+        CEqp | eqpOverfull b k -> failSer EqpOverfull+        _ -> msgAndSer destCStore+    Left slides -> return $ Left slides+    _ -> assert `failure` ggi++-- * Project++projectHuman :: MonadClientUI m+             => [Trigger] -> m (SlideOrCmd (RequestTimed AbProject))+projectHuman ts = do+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  tgtPos <- leaderTgtToPos+  tgt <- getsClient $ getTarget leader+  case tgtPos of+    Nothing -> failWith "last target invalid"+    Just pos | pos == bpos b -> failWith "cannot aim at oneself"+    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+        Left cause -> failWith cause+      modifyClient $ \cli -> cli { stgtMode = oldTgtMode+                                 , scursor = oldCursor+                                 , seps = oldEps }+      return outcome++projectPos :: MonadClientUI m+           => [Trigger] -> Point -> m (SlideOrCmd (RequestTimed AbProject))+projectPos ts tpos = do+  Kind.COps{cotile} <- getsState scops+  leader <- getLeaderUI+  eps <- getsClient seps+  sb <- getsState $ getActorBody leader+  let lid = blid sb+      spos = bpos sb+  Level{lxsize, lysize} <- getLevel lid+  do+      case bla lxsize lysize eps spos tpos of+        Nothing -> failSer ProjectAimOnself+        Just [] -> assert `failure` "project from the edge of level"+                          `twith` (spos, tpos, sb, ts)+        Just (pos : _) -> do+          lvl <- getLevel lid+          let t = lvl `at` pos+          if not $ Tile.isWalkable cotile t+            then failSer ProjectBlockTerrain+            else do+              actorBlind <-+                radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight leader+              mab <- getsState $ posToActor pos lid+              if maybe True (bproj . snd . fst) mab+              then if actorBlind+                   then failSer ProjectBlind+                   else projectEps ts tpos eps+              else failSer ProjectBlockActor++projectEps :: MonadClientUI m+           => [Trigger] -> Point -> Int+           -> m (SlideOrCmd (RequestTimed AbProject))+projectEps ts tpos eps = do+  leader <- getLeaderUI+  sb <- getsState $ getActorBody leader+  let cLegal = [CGround, CInv, CEqp]+      (verb1, object1) = case ts of+        [] -> ("aim", "item")+        tr : _ -> (verb tr, object tr)+      triggerSyms = triggerSymbols ts+      p item =+        let goodKind = if ' ' `elem` triggerSyms+                       then case strengthEqpSlot item of+                         Just (Effect.EqpSlotAddLight, _) -> True+                         Just _ -> False+                         Nothing -> True+                       else jsymbol item `elem` triggerSyms+            trange = totalRange item+        in goodKind+           && trange >= chessDist (bpos sb) tpos+  ggi <- getGroupItem p object1 verb1 cLegal cLegal+  case ggi of+    Right ((iid, _), CActor _ fromCStore) -> do+      return $ Right $ ReqProject tpos eps iid fromCStore+    Left slides -> return $ Left slides+    _ -> assert `failure` ggi++triggerSymbols :: [Trigger] -> [Char]+triggerSymbols [] = []+triggerSymbols (ApplyItem{symbol} : ts) = symbol : triggerSymbols ts+triggerSymbols (_ : ts) = triggerSymbols ts++-- * Apply++applyHuman :: MonadClientUI m+           => [Trigger] -> m (SlideOrCmd (RequestTimed AbApply))+applyHuman ts = do+  leader <- getLeaderUI+  actorBlind <- radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight leader+  let cLegal = [CGround, CInv, CEqp]+      (verb1, object1) = case ts of+        [] -> ("activate", "item")+        tr : _ -> (verb tr, object tr)+      triggerSyms = triggerSymbols ts+      blindScroll item = jsymbol item == '?' && actorBlind+      p item = not (blindScroll item)+               && if ' ' `elem` triggerSyms+                  then Effect.Applicable `elem` jfeature item+                  else jsymbol item `elem` triggerSyms+  ggi <- getGroupItem p object1 verb1 cLegal cLegal+  case ggi of+    Right ((iid, itemFull), CActor _ fromCStore) -> do+      let durable = Effect.Durable `elem` jfeature (itemBase itemFull)+          periodic = isJust+                     $ strengthFromEqpSlot Effect.EqpSlotPeriodic itemFull+      if durable && periodic+        then failSer DurablePeriodicAbuse+        else if (blindScroll $ itemBase itemFull)+             then failSer ApplyBlind+             else return $ Right $ ReqApply iid fromCStore+    Left slides -> return $ Left slides+    _ -> assert `failure` ggi++-- * AlterDir++-- | Ask for a direction and alter a tile, if possible.+alterDirHuman :: MonadClientUI m+              => [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)+      prompt = makePhrase ["What to", verb1 MU.:> "? [movement key"]+  me <- displayChoiceUI prompt emptyOverlay keys+  case me of+    Left slides -> failSlides slides+    Right e -> K.handleDir configVi configLaptop e (flip alterTile ts)+                                                   (failWith "never mind")++-- | Player tries to alter a tile using a feature.+alterTile :: MonadClientUI m+          => Vector -> [Trigger] -> m (SlideOrCmd (RequestTimed AbAlter))+alterTile dir ts = do+  Kind.COps{cotile} <- getsState scops+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  lvl <- getLevel $ 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 cotile alterFeats t+    feat : _ -> return $ Right $ ReqAlter tpos $ Just feat++alterFeatures :: [Trigger] -> [F.Feature]+alterFeatures [] = []+alterFeatures (AlterFeature{feature} : ts) = feature : alterFeatures ts+alterFeatures (_ : ts) = alterFeatures ts++-- | Guess and report why the bump command failed.+guessAlter :: Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> Msg+guessAlter cotile (F.OpenTo _ : _) t+  | Tile.isClosable cotile t = "already open"+guessAlter _ (F.OpenTo _ : _) _ = "cannot be opened"+guessAlter cotile (F.CloseTo _ : _) t+  | Tile.isOpenable cotile t = "already closed"+guessAlter _ (F.CloseTo _ : _) _ = "cannot be closed"+guessAlter _ _ _ = "never mind"++-- * TriggerTile++-- | Leader tries to trigger the tile he's standing on.+triggerTileHuman :: MonadClientUI m+                 => [Trigger] -> m (SlideOrCmd (RequestTimed AbTrigger))+triggerTileHuman ts = do+  tgtMode <- getsClient stgtMode+  if isJust tgtMode then do+    let getK tfs = case tfs of+          TriggerFeature {feature = F.Cause (Effect.Ascend k)} : _ -> Just k+          _ : rest -> getK rest+          [] -> Nothing+        mk = getK ts+    case mk of+      Nothing -> failWith  "never mind"+      Just k -> fmap Left $ tgtAscendHuman k+  else triggerTile ts++-- | Player tries to trigger a tile using a feature.+triggerTile :: MonadClientUI m+            => [Trigger] -> m (SlideOrCmd (RequestTimed AbTrigger))+triggerTile ts = do+  Kind.COps{cotile} <- getsState scops+  leader <- getLeaderUI+  b <- getsState $ getActorBody leader+  lvl <- getLevel $ blid b+  let t = lvl `at` bpos b+      triggerFeats = triggerFeatures ts+  case filter (\feat -> Tile.hasFeature cotile feat t) triggerFeats of+    [] -> failWith $ guessTrigger cotile triggerFeats t+    feat : _ -> do+      go <- verifyTrigger leader feat+      case go of+        Right () -> return $ Right $ ReqTrigger $ Just feat+        Left slides -> return $ Left slides++triggerFeatures :: [Trigger] -> [F.Feature]+triggerFeatures [] = []+triggerFeatures (TriggerFeature{feature} : ts) = feature : triggerFeatures ts+triggerFeatures (_ : ts) = triggerFeatures ts++-- | Verify important feature triggers, such as fleeing the dungeon.+verifyTrigger :: MonadClientUI m+              => ActorId -> F.Feature -> m (SlideOrCmd ())+verifyTrigger leader feat = case feat of+  F.Cause Effect.Escape{} -> do+    b <- getsState $ getActorBody leader+    side <- getsClient sside+    fact <- getsState $ (EM.! side) . sfactionD+    if isSpawnFact fact then failWith+      "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."+      else do+        (_, total) <- getsState $ calculateTotal b+        if total == 0 then do+          -- The player can back off at each of these steps.+          go1 <- displayMore ColorBW+                   "Afraid of the challenge? Leaving so soon and empty-handed?"+          if not go1 then failWith "Brave soul!"+          else do+             go2 <- displayMore ColorBW+                     "Next time try to grab some loot before escape!"+             if not go2 then failWith "Here's your chance!"+             else return $ Right ()+        else return $ Right ()+  _ -> return $ Right ()++-- | Guess and report why the bump command failed.+guessTrigger :: Kind.Ops TileKind -> [F.Feature] -> Kind.Id TileKind -> Msg+guessTrigger cotile fs@(F.Cause (Effect.Ascend k) : _) t+  | Tile.hasFeature cotile (F.Cause (Effect.Ascend (-k))) t =+    if k > 0 then "the way goes down, not up"+    else if k < 0 then "the way goes up, not down"+    else assert `failure` fs+guessTrigger _ fs@(F.Cause (Effect.Ascend k) : _) _ =+    if k > 0 then "cannot ascend"+    else if k < 0 then "cannot descend"+    else assert `failure` fs+guessTrigger _ _ _ = "never mind"++-- * StepToTarget++stepToTargetHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)+stepToTargetHuman = do+  tgtMode <- getsClient stgtMode+  -- Movement is legal only outside targeting mode.+  -- TODO: use this command for something in targeting mode.+  if isJust tgtMode then failWith "cannot move in targeting mode"+  else do+    leader <- getLeaderUI+    b <- getsState $ getActorBody leader+    tgtPos <- leaderTgtToPos+    case tgtPos of+      Nothing -> failWith "target not set"+      Just c | c == bpos b -> failWith "target reached"+      Just c -> do+        (_, mpath) <- getCacheBfsAndPath leader c+        case mpath of+          Nothing -> failWith "no route to target"+          Just [] -> assert `failure` (leader, b, bpos b, c)+          Just (p1 : _) -> do+            as <- getsState $ posToActors p1 (blid b)+            if not $ null as then+              failWith "actor in the path to target"+            else+              moveRunHuman False $ towards (bpos b) p1++-- * GameRestart; does not take time++gameRestartHuman :: MonadClientUI m => Text -> m (SlideOrCmd RequestUI)+gameRestartHuman t = do+  let msg = "You just requested a new" <+> t <+> "game."+  b1 <- displayMore ColorFull msg+  if not b1 then failWith "never mind"+  else do+    b2 <- displayYesNo ColorBW+            "Current progress will be lost! Really restart the game?"+    msg2 <- rndToAction $ oneOf+              [ "Yea, would be a pity to leave them all to die."+              , "Yea, a shame to get your own team stranded." ]+    if not b2 then failWith msg2+    else do+      leader <- getLeaderUI+      DebugModeCli{sdifficultyCli} <- getsClient sdebugCli+      Config{configHeroNames} <- askConfig+      return $ Right $ ReqUIGameRestart leader t sdifficultyCli configHeroNames++-- * GameExit; does not take time++gameExitHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)+gameExitHuman = do+  go <- displayYesNo ColorFull "Really save and exit?"+  if go then do+    leader <- getLeaderUI+    DebugModeCli{sdifficultyCli} <- getsClient sdebugCli+    return $ Right $ ReqUIGameExit leader sdifficultyCli+  else failWith "Save and exit canceled."++-- * GameSave; does not take time++gameSaveHuman :: MonadClientUI m => m RequestUI+gameSaveHuman = do+  -- TODO: do not save to history:+  msgAdd "Saving game backup."+  return ReqUIGameSave++-- * Automate; does not take time++automateHuman :: MonadClientUI m => m (SlideOrCmd RequestUI)+automateHuman = do+  -- BFS is not updated while automated, which would lead to corruption.+  modifyClient $ \cli -> cli {stgtMode = Nothing}+  -- TODO: do not save to history:+  go <- displayMore ColorBW "Ceding control to AI (ESC to regain)."+  if not go+    then failWith "Automation canceled."+    else return $ Right ReqUIAutomate
+ Game/LambdaHack/Client/UI/HandleHumanLocalClient.hs view
@@ -0,0 +1,645 @@+-- | Semantics of 'HumanCmd' client commands that do not return+-- server commands. None of such commands takes game time.+-- TODO: document+module Game.LambdaHack.Client.UI.HandleHumanLocalClient+  ( -- * Assorted commands+    gameDifficultyCycle+  , pickLeaderHuman, memberCycleHuman, memberBackHuman+  , describeItemHuman, allOwnedHuman+  , selectActorHuman, selectNoneHuman, clearHuman, repeatHuman, recordHuman+  , historyHuman, markVisionHuman, markSmellHuman, markSuspectHuman+  , helpHuman, mainMenuHuman, macroHuman+    -- * Commands specific to targeting+  , moveCursorHuman, tgtFloorHuman, tgtEnemyHuman+  , tgtUnknownHuman, tgtItemHuman, tgtStairHuman, tgtAscendHuman+  , epsIncrHuman, tgtClearHuman, cancelHuman, acceptHuman+  ) where++-- Cabal+import qualified Paths_LambdaHack as Self (version)++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 qualified Data.Map.Strict as M+import Data.Maybe+import Data.Monoid+import Data.Ord+import qualified Data.Text as T+import Data.Version+import Game.LambdaHack.Client.UI.Frontend (frontendName)+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Client.BfsClient+import Game.LambdaHack.Client.CommonClient+import qualified Game.LambdaHack.Client.Key as K+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd+import Game.LambdaHack.Client.UI.InventoryClient+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 Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemDescription+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.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Content.TileKind++-- * GameDifficultyCycle++gameDifficultyCycle :: MonadClientUI m => m ()+gameDifficultyCycle = do+  DebugModeCli{sdifficultyCli} <- getsClient sdebugCli+  let d = if sdifficultyCli >= difficultyBound then 1 else sdifficultyCli + 1+  modifyClient $ \cli -> cli {sdebugCli = (sdebugCli cli) {sdifficultyCli = d}}+  msgAdd $ "Next game difficulty set to" <+> tshow d <> "."++-- * PickLeader++pickLeaderHuman :: MonadClientUI m => Int -> m Slideshow+pickLeaderHuman k = do+  cops <- getsState scops+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  s <- getState+  case tryFindHeroK s side k of+    _ | isAllMoveFact cops fact -> failMsg msgCannotChangeLeader+    Nothing -> failMsg "No such member of the party."+    Just (aid, _) -> do+      void $ pickLeader True aid+      return mempty++-- * MemberCycle++-- | Switches current member to the next on the level, if any, wrapping.+memberCycleHuman :: MonadClientUI m => m Slideshow+memberCycleHuman = memberCycle True++-- * MemberBack++-- | Switches current member to the previous in the whole dungeon, wrapping.+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++describeItemC :: MonadClientUI m => Container -> m Slideshow+describeItemC c = do+  let subject body = partActor body+      verbSha body activeItems = if calmEnough body activeItems+                                 then "notice"+                                 else "paw distractedly"+      shaBlurb body activeItems = makePhrase+        [MU.Capitalize+         $ MU.SubjectVerbSg (subject body) (verbSha body activeItems)]+      stdBlurb body = makePhrase+        [MU.Capitalize $ MU.SubjectVerbSg (subject body) "see"]+  itemToF <- itemToFullClient+  let verb = "describe"+  ggi <- getStoreItem shaBlurb stdBlurb verb c+  case ggi of+    Right ((iid, _), _) ->+      overlayToSlideshow "" $ itemDesc (storeFromC c) (itemToF iid 1)+    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)++-- * 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 = do+  leader <- getLeaderUI+  body <- getsState $ getActorBody leader+  wasMemeber <- getsClient $ ES.member leader . sselected+  let upd = if wasMemeber+            then ES.delete leader  -- already selected, deselect instead+            else ES.insert leader+  modifyClient $ \cli -> cli {sselected = upd $ sselected cli}+  let subject = partActor body+  msgAdd $ makeSentence [subject, if wasMemeber+                                  then "deselected"+                                  else "selected"]+  return mempty++-- * SelectNone++selectNoneHuman :: (MonadClientUI m, MonadClient m) => m ()+selectNoneHuman = do+  side <- getsClient sside+  lidV <- viewedLevel+  oursAssocs <- getsState $ actorRegularAssocs (== side) lidV+  let ours = ES.fromList $ map fst oursAssocs+  oldSel <- getsClient sselected+  let wasNone = ES.null $ ES.intersection ours oldSel+      upd = if wasNone+            then ES.union  -- already all deselected; select all instead+            else ES.difference+  modifyClient $ \cli -> cli {sselected = upd (sselected cli) ours}+  let subject = "all party members on the level"+  msgAdd $ makeSentence [subject, if wasNone+                                  then "selected"+                                  else "deselected"]++-- * Clear++-- | Clear current messages, show the next screen if any.+clearHuman :: Monad m => m ()+clearHuman = return ()++-- * Repeat++-- Note that walk followed by repeat should not be equivalent to run,+-- because the player can really use a command that does not stop+-- at terrain change or when walking over items.+repeatHuman :: MonadClient m => Int -> m ()+repeatHuman n = do+  (_, seqPrevious, k) <- getsClient slastRecord+  let macro = concat $ replicate n $ reverse seqPrevious+  modifyClient $ \cli -> cli {slastPlay = macro ++ slastPlay cli}+  let slastRecord = ([], [], if k == 0 then 0 else maxK)+  modifyClient $ \cli -> cli {slastRecord}++maxK :: Int+maxK = 100++-- * Record++recordHuman :: MonadClientUI m => m Slideshow+recordHuman = do+  (_seqCurrent, seqPrevious, k) <- getsClient slastRecord+  case k of+    0 -> do+      let slastRecord = ([], [], maxK)+      modifyClient $ \cli -> cli {slastRecord}+      promptToSlideshow $ "Macro will be recorded for up to"+                          <+> tshow maxK <+> "steps."+    _ -> do+      let slastRecord = (seqPrevious, [], 0)+      modifyClient $ \cli -> cli {slastRecord}+      promptToSlideshow $ "Macro recording interrupted after"+                          <+> tshow (maxK - k - 1) <+> "steps."++-- * History++historyHuman :: MonadClientUI m => m Slideshow+historyHuman = do+  history <- getsClient shistory+  arena <- getArenaUI+  local <- getsState $ getLocalTime arena+  global <- getsState stime+  let msg = makeSentence+        [ "You survived for"+        , MU.CarWs (global `timeFitUp` timeTurn) "half-second turn"+        , "(this level:"+        , MU.Text (tshow (local `timeFitUp` timeTurn)) MU.:> ")" ]+        <+> "Past messages:"+  overlayToBlankSlideshow msg $ renderHistory history++-- * MarkVision, MarkSmell, MarkSuspect++markVisionHuman :: MonadClientUI m => m ()+markVisionHuman = do+  modifyClient toggleMarkVision+  cur <- getsClient smarkVision+  msgAdd $ "Visible area display toggled" <+> if cur then "on." else "off."++markSmellHuman :: MonadClientUI m => m ()+markSmellHuman = do+  modifyClient toggleMarkSmell+  cur <- getsClient smarkSmell+  msgAdd $ "Smell display toggled" <+> if cur then "on." else "off."++markSuspectHuman :: MonadClientUI m => m ()+markSuspectHuman = do+  modifyClient toggleMarkSuspect+  cur <- getsClient smarkSuspect+  msgAdd $ "Suspect terrain display toggled" <+> if cur then "on." else "off."++-- * Help++-- | Display command help.+helpHuman :: MonadClientUI m => m Slideshow+helpHuman = do+  keyb <- askBinding+  return $! keyHelp keyb++-- * MainMenu++-- TODO: merge with the help screens better+-- | Display the main menu.+mainMenuHuman :: MonadClientUI m => m Slideshow+mainMenuHuman = do+  Kind.COps{corule} <- getsState scops+  Binding{brevMap, bcmdList} <- askBinding+  scurDifficulty <- getsClient scurDifficulty+  DebugModeCli{sdifficultyCli} <- getsClient sdebugCli+  let stripFrame t = map (T.tail . T.init) $ tail . init $ T.lines t+      pasteVersion art =+        let pathsVersion = rpathsVersion $ Kind.stdRuleset corule+            version = " Version " ++ showVersion pathsVersion+                      ++ " (frontend: " ++ frontendName+                      ++ ", engine: LambdaHack " ++ showVersion Self.version+                      ++ ") "+            versionLen = length version+        in init art ++ [take (80 - versionLen) (last art) ++ version]+      kds =  -- key-description pairs+        let showKD cmd km = (K.showKM km, HumanCmd.cmdDescription cmd)+            revLookup cmd = maybe ("", "") (showKD cmd) $ M.lookup cmd brevMap+            cmds = [ (K.showKM km, desc)+                   | (km, (desc, [HumanCmd.CmdMenu], cmd)) <- bcmdList,+                     cmd /= HumanCmd.GameDifficultyCycle ]+        in [+             (fst (revLookup HumanCmd.Cancel), "back to playing")+           , (fst (revLookup HumanCmd.Accept), "see more help")+           ]+           ++ cmds+           ++ [ (fst ( revLookup HumanCmd.GameDifficultyCycle)+                     , "next game difficulty"+                       <+> tshow sdifficultyCli+                       <+> "(current"+                       <+> tshow scurDifficulty <> ")" ) ]+      bindingLen = 25+      bindings =  -- key bindings to display+        let fmt (k, d) = T.justifyLeft bindingLen ' '+                         $ T.justifyLeft 7 ' ' k <> " " <> d+        in map fmt kds+      overwrite =  -- overwrite the art with key bindings+        let over [] line = ([], T.pack line)+            over bs@(binding : bsRest) line =+              let (prefix, lineRest) = break (=='{') line+                  (braces, suffix)   = span  (=='{') lineRest+              in if length braces == 25+                 then (bsRest, T.pack prefix <> binding+                               <> T.drop (T.length binding - bindingLen)+                                         (T.pack suffix))+                 else (bs, T.pack line)+        in snd . mapAccumL over bindings+      mainMenuArt = rmainMenuArt $ Kind.stdRuleset corule+      menuOverlay =  -- TODO: switch to Text and use T.justifyLeft+        overwrite $ pasteVersion $ map T.unpack $ stripFrame mainMenuArt+  case menuOverlay of+    [] -> assert `failure` "empty Main Menu overlay" `twith` mainMenuArt+    hd : tl -> overlayToBlankSlideshow hd (toOverlay tl)+               -- TODO: keys don't work if tl/=[]++-- * Macro++macroHuman :: MonadClient m => [String] -> m ()+macroHuman kms =+  modifyClient $ \cli -> cli {slastPlay = map K.mkKM kms ++ slastPlay cli}++-- * MoveCursor++-- | 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} -> 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.+      let is = lvl `atI` 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)++-- * 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++-- * 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++-- * TgtAscend++-- | Change the displayed level in targeting mode to (at most)+-- k levels shallower. Enters targeting mode, if not already in one.+tgtAscendHuman :: MonadClientUI m => Int -> m Slideshow+tgtAscendHuman k = do+  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops+  dungeon <- getsState sdungeon+  scursorOld <- getsClient scursor+  cursorPos <- cursorToPos+  lidV <- viewedLevel+  lvl <- getLevel lidV+  let rightStairs = case cursorPos of+        Nothing -> Nothing+        Just cpos ->+          let tile = lvl `at` cpos+          in if Tile.hasFeature cotile (F.Cause $ Effect.Ascend k) tile+             then Just cpos+             else Nothing+  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+      nlvl <- getLevel nln+      -- Do not freely reveal the other end of the stairs.+      let ascDesc (F.Cause (Effect.Ascend _)) = True+          ascDesc _ = False+          scursor =+            if any ascDesc $ tfeature $ okind (nlvl `at` npos)+            then TPoint nln npos  -- already known as an exit, focus on it+            else scursorOld  -- unknown, do not reveal+      modifyClient $ \cli -> cli {scursor, stgtMode = Just (TgtMode nln)}+      doLook+    Nothing ->  -- no stairs in the right direction+      case ascendInBranch dungeon k lidV of+        [] -> failMsg "no more levels in this direction"+        nln : _ -> do+          modifyClient $ \cli -> cli {stgtMode = Just (TgtMode nln)}+          doLook++-- * EpsIncr++-- | Tweak the @eps@ parameter of the targeting digital line.+epsIncrHuman :: 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++-- * TgtClear++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++-- * Cancel++-- | Cancel something, e.g., targeting mode, resetting the cursor+-- to the position of the leader. Chosen target is not invalidated.+cancelHuman :: MonadClientUI m => m Slideshow -> m Slideshow+cancelHuman h = do+  stgtMode <- getsClient stgtMode+  if isJust stgtMode+    then targetReject+    else h  -- nothing to cancel right now, treat this as a command invocation++-- | End targeting mode, rejecting the current position.+targetReject :: MonadClientUI m => m Slideshow+targetReject = do+  modifyClient $ \cli -> cli {stgtMode = Nothing}+  failMsg "targeting canceled"++-- * Accept++-- | Accept something, e.g., targeting mode, keeping cursor where it was.+-- Or perform the default action, if nothing needs accepting.+acceptHuman :: MonadClientUI m => m Slideshow -> m Slideshow+acceptHuman h = do+  stgtMode <- getsClient stgtMode+  if isJust stgtMode+    then do+      targetAccept+      return mempty+    else h  -- nothing to accept right now, treat this as a command invocation++-- | End targeting mode, accepting the current position.+targetAccept :: MonadClientUI m => m ()+targetAccept = do+  endTargeting+  endTargetingMsg+  modifyClient $ \cli -> cli {stgtMode = Nothing}++-- | End targeting mode, accepting the current position.+endTargeting :: MonadClientUI m => m ()+endTargeting = do+  leader <- getLeaderUI+  scursor <- getsClient scursor+  modifyClient $ updateTarget leader $ const $ Just scursor++endTargetingMsg :: MonadClientUI m => m ()+endTargetingMsg = do+  leader <- getLeaderUI+  (targetMsg, _) <- targetDescLeader leader+  subject <- partAidLeader leader+  msgAdd $ makeSentence [MU.SubjectVerbSg subject "target", MU.Text targetMsg]
+ Game/LambdaHack/Client/UI/HumanCmd.hs view
@@ -0,0 +1,166 @@+-- | Abstract syntax human player commands.+module Game.LambdaHack.Client.UI.HumanCmd+  ( CmdCategory(..), HumanCmd(..), Trigger(..)+  , noRemoteHumanCmd, categoryDescription, cmdDescription+  ) where++import Control.Exception.Assert.Sugar+import Data.Text (Text)+import qualified NLP.Miniutter.English as MU++import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Vector++data CmdCategory =+    CmdMenu | CmdMove | CmdItem | CmdTgt | CmdAuto | CmdMeta+  | CmdDebug | CmdMinimal+  deriving (Show, Read, Eq)++categoryDescription :: CmdCategory -> Text+categoryDescription CmdMenu = "Main Menu"+categoryDescription CmdMove = "Terrain exploration and alteration"+categoryDescription CmdItem = "Item use"+categoryDescription CmdTgt = "Targeting"+categoryDescription CmdAuto = "Automation"+categoryDescription CmdMeta = "Assorted"+categoryDescription CmdDebug = "Debug"+categoryDescription CmdMinimal = "Minimal cheat sheet for casual play"++-- | Abstract syntax of player commands.+data HumanCmd =+    -- Global.+    -- These usually take time.+    Move !Vector+  | Run !Vector+  | Wait+  | MoveItem ![CStore] !CStore !Text !Text !Bool+  | Project     ![Trigger]+  | Apply       ![Trigger]+  | AlterDir    ![Trigger]+  | TriggerTile ![Trigger]+  | StepToTarget+    -- Below this line, commands do not take time.+  | GameRestart !Text+  | GameExit+  | GameSave+  | Automate+    -- Local.+    -- Below this line, commands do not notify the server.+  | GameDifficultyCycle+  | PickLeader !Int+  | MemberCycle+  | MemberBack+  | DescribeItem !CStore+  | AllOwned+  | SelectActor+  | SelectNone+  | Clear+  | Repeat !Int+  | Record+  | History+  | MarkVision+  | MarkSmell+  | MarkSuspect+  | Help+  | MainMenu+  | Macro !Text ![String]+    -- These are mostly related to targeting.+  | MoveCursor !Vector !Int+  | TgtFloor+  | TgtEnemy+  | TgtUnknown+  | TgtItem+  | TgtStair !Bool+  | TgtAscend !Int+  | EpsIncr !Bool+  | TgtClear+  | Cancel+  | Accept+  deriving (Show, Read, Eq, Ord)++data Trigger =+    ApplyItem {verb :: !MU.Part, object :: !MU.Part, symbol :: !Char}+  | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature}+  | TriggerFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature}+  deriving (Show, Read, Eq, Ord)++-- | Commands that are forbidden on a remote level, because they+-- would usually take time when invoked on one.+-- Note that some commands that take time are not included,+-- because they don't take time in targeting mode.+noRemoteHumanCmd :: HumanCmd -> Bool+noRemoteHumanCmd cmd = case cmd of+  Wait          -> True+  MoveItem{}    -> True+  Apply{}       -> True+  AlterDir{}    -> True+  StepToTarget  -> True+  _             -> False++-- | Description of player commands.+cmdDescription :: HumanCmd -> Text+cmdDescription cmd = case cmd of+  Move v      -> "move" <+> compassText v+  Run v       -> "run" <+> compassText v+  Wait        -> "wait"+  MoveItem _ _ verb object _ -> verb <+> object+  Project ts  -> triggerDescription ts+  Apply ts    -> triggerDescription ts+  AlterDir ts -> triggerDescription ts+  TriggerTile ts -> triggerDescription ts+  StepToTarget -> "make one step towards the target"++  GameRestart t -> makePhrase ["new", MU.Capitalize $ MU.Text t, "game"]+  GameExit    -> "save and exit"+  GameSave    -> "save game"+  Automate    -> "automate faction (ESC to retake control)"++  GameDifficultyCycle -> "cycle difficulty of the next game"+  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"+  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"+  Help        -> "display help"+  MainMenu    -> "display the Main Menu"+  Macro t _   -> t++  MoveCursor v 1 -> "move cursor" <+> compassText v+  MoveCursor v k ->+    "move cursor up to" <+> tshow k <+> "steps" <+> compassText v+  TgtFloor    -> "cycle targeting mode"+  TgtEnemy    -> "target enemy"+  TgtUnknown  -> "target the closest unknown spot"+  TgtItem     -> "target the closest item"+  TgtStair up -> "target the closest stairs" <+> if up then "up" else "down"+  TgtAscend k | k == 1  -> "target next shallower level"+  TgtAscend k | k >= 2  -> "target" <+> tshow k    <+> "levels shallower"+  TgtAscend k | k == -1 -> "target next deeper level"+  TgtAscend k | k <= -2 -> "target" <+> tshow (-k) <+> "levels deeper"+  TgtAscend _ -> assert `failure` "void level change when targeting"+                        `twith` cmd+  EpsIncr True  -> "swerve targeting line"+  EpsIncr False -> "unswerve targeting line"+  TgtClear    -> "clear target/cursor"+  Cancel      -> "cancel action, open Main Menu"+  Accept      -> "accept choice"++triggerDescription :: [Trigger] -> Text+triggerDescription [] = "trigger a thing"+triggerDescription (t : _) = makePhrase [verb t, object t]
+ Game/LambdaHack/Client/UI/InventoryClient.hs view
@@ -0,0 +1,402 @@+-- | Inventory management and party cycling.+-- TODO: document+module Game.LambdaHack.Client.UI.InventoryClient+  ( failMsg, msgCannotChangeLeader+  , 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+             => (Item -> Bool)  -- ^ which items to consider suitable+             -> MU.Part   -- ^ name of the item group+             -> MU.Part   -- ^ the verb describing the action+             -> [CStore]  -- ^ initial legal containers+             -> [CStore]  -- ^ legal containers after Calm taken into account+             -> m (SlideOrCmd ((ItemId, ItemFull), Container))+getGroupItem p itemsName verb cLegalRaw cLegalAfterCalm = do+  leader <- getLeaderUI+  getCStoreBag <- getsState $ \s cstore -> getCBag (CActor leader cstore) s+  let cNotEmpty = not . EM.null . getCStoreBag+      cLegal = filter cNotEmpty cLegalAfterCalm  -- don't display empty stores+      tsuitable = const $ makePhrase [MU.Capitalize (MU.Ws itemsName)]+  getItem p (\b _ -> tsuitable b) tsuitable verb+          (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+  soc <- getItem (const True) (\_ _ -> "Items") (const "Items") verb+                 (map (CActor leader) cLegalRaw)+                 (map (CActor leader) cLegalAfterCalm)+                 askWhenLone INone+  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] -> Text)+                                 -- ^ how to describe suitable items in CSha+             -> (Actor -> Text)  -- ^ how to describe suitable items elsewhere+             -> MU.Part          -- ^ the verb describing the action+             -> Container        -- ^ initial container+             -> m (SlideOrCmd ((ItemId, ItemFull), Container))+getStoreItem shaBlurb stdBlurb verb cInitial = do+  leader <- getLeaderUI+  let allStores = map (CActor leader) [CEqp, CInv, CSha, CGround]+      cLegalRaw = cInitial : delete cInitial allStores+  getItem (const True) shaBlurb stdBlurb verb cLegalRaw cLegalRaw+          True ISuitable++data ItemDialogState = INone | ISuitable | IAll+  deriving (Show, Eq)++-- | Let the human player choose a single, preferably suitable,+-- item from a list of items.+getItem :: MonadClientUI m+        => (Item -> Bool)   -- ^ which items to consider suitable+        -> (Actor -> [ItemFull] -> Text)+                            -- ^ how to describe suitable items in CSha+        -> (Actor -> Text)  -- ^ how to describe suitable items elsewhere+        -> MU.Part          -- ^ the verb describing the action+        -> [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 p tshaSuit tsuitable verb cLegalRaw cLegal askWhenLone initalState = do+  leader <- getLeaderUI+  accessCBag <- getsState $ flip getCBag+  let storeAssocs = EM.assocs . accessCBag+      allAssocs = concatMap storeAssocs cLegal+      rawAssocs = concatMap storeAssocs cLegalRaw+  case (cLegal, allAssocs) of+    ([cStart], [(iid, k)]) | not askWhenLone -> do+      itemToF <- itemToFullClient+      return $ Right ((iid, itemToF iid k), cStart)+    (_ : _, _ : _) -> do+      let groundCs = filter ((== CGround) . storeFromC) cLegal+      mapM_ (updateItemSlot (Just leader)) $+        concatMap (EM.keys . accessCBag) groundCs+      transition p tshaSuit tsuitable verb 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++-- TODO: m is no longer needed and perhaps this can be simplified even more+data DefItemKey m = DefItemKey+  { defLabel  :: Text+  , defCond   :: Bool+  , defAction :: K.Key -> m (SlideOrCmd ((ItemId, ItemFull), Container))+  }++transition :: forall m. MonadClientUI m+           => (Item -> Bool)   -- ^ which items to consider suitable+           -> (Actor -> [ItemFull] -> Text)+                               -- ^ how to describe suitable items in CSha+           -> (Actor -> Text)  -- ^ how to describe suitable items elsewhere+           -> MU.Part          -- ^ the verb describing the action+           -> [Container]+           -> ItemDialogState+           -> m (SlideOrCmd ((ItemId, ItemFull), Container))+transition _ _ _ verb [] iDS = assert `failure` (verb, iDS)+transition psuit tshaSuit tsuitable verb+           cLegal@(cCur:cRest) itemDialogState = do+  cops <- getsState scops+  (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 s iid _ = psuit (getItemBody iid s)+  bagSuit <- getsState $ \s -> EM.filterWithKey (filterP s) bag+  let bagLetterSlots = EM.filter (`EM.member` bag) letterSlots+      bagNumberSlots = IM.filter (`EM.member` bag) numberSlots+      suitableLetterSlots = EM.filter (`EM.member` bagSuit) letterSlots+      keyDefs :: [(K.Key, DefItemKey m)]+      keyDefs = filter (defCond . snd)+        [ (K.Char '?', DefItemKey+           { defLabel = "?"+           , defCond = True+           , defAction = \_ -> case itemDialogState of+               INone ->+                 if EM.null bagSuit+                 then transition psuit tshaSuit tsuitable verb cLegal IAll+                 else transition psuit tshaSuit tsuitable verb cLegal ISuitable+               ISuitable | bag /= bagSuit ->+                 transition psuit tshaSuit tsuitable verb cLegal IAll+               _ -> transition psuit tshaSuit tsuitable verb cLegal INone+           })+        , (K.Char '/', DefItemKey+           { defLabel = "/"+           , defCond = length cLegal > 1+           , defAction = \_ -> transition psuit tshaSuit tsuitable verb+                                          (cRest ++ [cCur]) 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+           , 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 (isAllMoveFact cops fact+                            || 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+               transition psuit tshaSuit tsuitable verb newLegal itemDialogState+           })+        , (K.BackTab, DefItemKey+           { defLabel = "SHIFT-TAB"+           , defCond = not (isAllMoveFact cops fact || 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+               transition psuit tshaSuit tsuitable verb 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+      tsuit = if storeFromC cCur == CSha+              then tshaSuit body activeItems+              else tsuitable body+      (labelLetterSlots, bagFiltered, prompt) =+        case itemDialogState of+          INone     -> (suitableLetterSlots,+                        EM.empty,+                        makePhrase ["What to", verb] <+> ppCur <> "?")+          ISuitable -> (suitableLetterSlots,+                        bagSuit,+                        tsuit <+> ppCur <> ":")+          IAll      -> (bagLetterSlots,+                        bag,+                        "Items" <+> ppCur <> ":")+  io <- itemOverlay (storeFromC cCur) bagFiltered+  runDefItemKey keyDefs lettersDef io labelLetterSlots prompt++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+  cops <- getsState scops+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  leader <- getLeaderUI+  body <- getsState $ getActorBody leader+  hs <- partyAfterLeader leader+  case filter (\(_, b) -> blid b == blid body) hs of+    _ | isAllMoveFact cops fact -> failMsg msgCannotChangeLeader+    [] -> 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+  cops <- getsState scops+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  leader <- getLeaderUI+  hs <- partyAfterLeader leader+  case reverse hs of+    _ | isAllMoveFact cops fact -> failMsg msgCannotChangeLeader+    [] -> 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++msgCannotChangeLeader :: Msg+msgCannotChangeLeader = "leader change is automatic for your team"++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
+ Game/LambdaHack/Client/UI/KeyBindings.hs view
@@ -0,0 +1,141 @@+-- | Binding of keys to commands.+-- No operation in this module involves the 'State' or 'Action' type.+module Game.LambdaHack.Client.UI.KeyBindings+  ( Binding(..), stdBinding, keyHelp+  ) where++import Control.Arrow (second)+import qualified Data.Char as Char+import Data.List+import qualified Data.Map.Strict as M+import Data.Text (Text)+import qualified Data.Text as T+import Data.Tuple (swap)++import qualified Game.LambdaHack.Client.Key as K+import Game.LambdaHack.Client.UI.Config+import Game.LambdaHack.Client.UI.Content.KeyKind+import Game.LambdaHack.Client.UI.HumanCmd+import Game.LambdaHack.Common.Msg++-- | Bindings and other information about human player commands.+data Binding = Binding+  { bcmdMap  :: !(M.Map K.KM (Text, [CmdCategory], HumanCmd))+                                        -- ^ binding of keys to commands+  , bcmdList :: ![(K.KM, (Text, [CmdCategory], HumanCmd))]+                                        -- ^ the properly ordered list+                                        --   of commands for the help menu+  , brevMap  :: !(M.Map HumanCmd K.KM)  -- ^ and from commands to their keys+  }++-- | Binding of keys to movement and other standard commands,+-- as well as commands defined in the config file.+stdBinding :: KeyKind  -- ^ default key bindings from the content+           -> 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 }+                     , ([CmdMeta], PickLeader k) )+      cmdWithHelp = rhumanCommands copsClient ++ configCommands+      cmdAll =+        cmdWithHelp+        ++ [(K.mkKM "KP_Begin", ([CmdMove], Wait))]+        ++ K.moveBinding configVi configLaptop (\v -> ([CmdMove], Move v))+                                               (\v -> ([CmdMove], Run v))+        ++ fmap heroSelect [0..6]+      mkDescribed (cats, cmd) = (cmdDescription cmd, cats, cmd)+  in Binding+  { bcmdMap = M.fromList $ map (second mkDescribed) cmdAll+  , bcmdList = map (second mkDescribed) cmdWithHelp+  , brevMap = M.fromList $ map swap $ map (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"+      , "(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."+      , ""+      , "               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"+      , ""+      , "In targeting mode the very same keys move the targeting cursor."+      , "Press '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)."+      , ""+      , "Search, loot, open and attack by bumping into walls, doors and enemies."+      , "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."+      ]+    categoryBlurb =+      [ ""+      , "Press SPACE to see the next page of command descriptions."+      ]+    lastBlurb =+      [ ""+      , "For more playing instructions see file PLAYING.md."+      , "Press SPACE to clear the messages and see the map again."+      ]+    fmt k h = T.justifyRight 72 ' '+              $ T.justifyLeft 15 ' ' k+                <> T.justifyLeft 41 ' ' h+    fmts s = " " <> T.justifyLeft 71 ' ' s+    minimalText = map fmts minimalBlurb+    movText = map fmts movBlurb+    minCatText = map fmts minCatBlurb+    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 ]+    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]"] ++ [""]+      ++ movText ++ [moreMsg]+    , [categoryDescription CmdMove <> ". [press SPACE to advance]"] ++ [""]+      ++ [keyCaption] ++ keys CmdMove ++ categoryText ++ [moreMsg]+    , [categoryDescription CmdItem <> ". [press SPACE to advance]"] ++ [""]+      ++ [keyCaption] ++ keys CmdItem ++ categoryText ++ [moreMsg]+    , [categoryDescription CmdTgt <> ". [press SPACE to advance]"] ++ [""]+      ++ [keyCaption] ++ keys CmdTgt ++ categoryText ++ [moreMsg]+    , [categoryDescription CmdAuto <> ". [press SPACE to advance]"] ++ [""]+      ++ [keyCaption] ++ keys CmdAuto ++ categoryText ++ [moreMsg]+    , [categoryDescription CmdMeta <> "."] ++ [""]+      ++ [keyCaption] ++ keys CmdMeta ++ lastText+    ]
+ Game/LambdaHack/Client/UI/MonadClientUI.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE RankNTypes #-}+-- | Client monad for interacting with a human through UI.+module Game.LambdaHack.Client.UI.MonadClientUI+  ( -- * Client UI monad+    MonadClientUI( getsSession  -- exposed only to be implemented, not used+                 , liftIO  -- exposed only to be implemented, not used+                 )+  , SessionUI(..)+    -- * Display and key input+  , ColorMode(..)+  , promptGetKey, getKeyOverlayCommand, getInitConfirms+  , displayFrame, displayDelay, displayFrames, displayActorStart, drawOverlay+    -- * Assorted primitives+  , stopPlayBack, stopRunning, askConfig, askBinding+  , syncFrames, tryTakeMVarSescMVar, scoreToSlideshow+  , getLeaderUI, getArenaUI, viewedLevel+  , targetDescLeader, targetDescCursor+  , leaderTgtToPos, leaderTgtAims, cursorToPos+  ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+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++import Game.LambdaHack.Client.BfsClient+import Game.LambdaHack.Client.CommonClient+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.DrawClient+import Game.LambdaHack.Client.UI.Frontend as Frontend+import Game.LambdaHack.Client.UI.KeyBindings+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.HighScore as HighScore+import Game.LambdaHack.Common.ItemDescription+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 Game.LambdaHack.Common.State+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@.+data SessionUI = SessionUI+  { schanF   :: !ChanFrontend       -- ^ connection with the frontend+  , sbinding :: !Binding            -- ^ binding of keys to commands+  , sescMVar :: !(Maybe (MVar ()))+  , sconfig  :: !Config+  }++class MonadClient m => MonadClientUI m where+  getsSession  :: (SessionUI -> a) -> m a+  liftIO       :: IO a -> m a++-- | Read a keystroke received from the frontend.+readConnFrontend :: MonadClientUI m => m K.KM+readConnFrontend = do+  ChanFrontend{responseF} <- getsSession schanF+  liftIO $ atomically $ readTQueue responseF++-- | Write a UI request to the frontend.+writeConnFrontend :: MonadClientUI m => FrontReq -> m ()+writeConnFrontend efr = do+  ChanFrontend{requestF} <- getsSession schanF+  liftIO $ atomically $ writeTQueue requestF efr++promptGetKey :: MonadClientUI m => [K.KM] -> SingleFrame -> m K.KM+promptGetKey frontKM frontFr = do+  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+      -- 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+      writeConnFrontend FrontKey{..}+      readConnFrontend+  (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 onBlank overlay = do+  frame <- drawOverlay onBlank ColorFull overlay+  promptGetKey [] frame++-- | Display a slideshow, awaiting confirmation for each slide except the last.+getInitConfirms :: MonadClientUI m+                => ColorMode -> [K.KM] -> Slideshow -> m Bool+getInitConfirms dm frontClear slides = do+  let (onBlank, ovs) = slideshow slides+  frontSlides <- drawOverlays onBlank dm ovs+  -- The first two cases are optimizations:+  case frontSlides of+    [] -> return True+    [x] -> do+      displayFrame False $ Just x+      return True+    _ -> do+      writeConnFrontend FrontSlides{..}+      km <- readConnFrontend+      -- Don't clear ESC marker here, because the wait for confirms may+      -- 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+  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)++-- | 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).+displayActorStart :: MonadClientUI m => Actor -> Frames -> m ()+displayActorStart b frs = do+  mapM_ (displayFrame False) frs+  let ageDisp displayed = EM.insert (blid b) (btime b) displayed+  modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli}++-- | Draw the current level with the overlay on top.+drawOverlay :: MonadClientUI m => Bool -> ColorMode -> Overlay -> m SingleFrame+drawOverlay sfBlank@True _ sfTop = do+  let sfLevel = []+      sfBottom = []+  return $! SingleFrame {..}+drawOverlay sfBlank@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+  bfsmpath <- maybe (return Nothing) pathFromLeader mleader+  tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader+  cursorDesc <- targetDescCursor+  draw sfBlank dm lid cursorPos tgtPos bfsmpath cursorDesc tgtDesc sfTop++drawOverlays :: MonadClientUI m+             => Bool -> ColorMode -> [Overlay] -> m [SingleFrame]+drawOverlays _ _ [] = return []+drawOverlays sfBlank dm (topFirst : rest) = do+  fistFrame <- drawOverlay sfBlank dm topFirst+  let f topNext = fistFrame {sfTop = topNext}+  return $! fistFrame : map f rest  -- keep @rest@ lazy for responsiveness++stopPlayBack :: MonadClientUI m => m ()+stopPlayBack = do+  modifyClient $ \cli -> cli+    { slastPlay = []+    , slastRecord = let (seqCurrent, seqPrevious, _) = slastRecord cli+                    in (seqCurrent, seqPrevious, 0)+    , swaitTimes = - swaitTimes cli+    }+  stopRunning++stopRunning :: MonadClientUI m => m ()+stopRunning = do+  srunning <- getsClient srunning+  case srunning of+    Nothing -> return ()+    Just RunParams{runLeader} -> do+      -- Switch to the original leader, from before the run start, unless dead.+      cops <- getsState scops+      side <- getsClient sside+      fact <- getsState $ (EM.! side) . sfactionD+      arena <- getArenaUI+      s <- getState+      when (memActor runLeader arena s && not (isAllMoveFact cops fact)) $+        modifyClient $ updateLeader runLeader s+      modifyClient (\cli -> cli { srunning = Nothing })++askConfig :: MonadClientUI m => m Config+askConfig = getsSession sconfig++-- | Get the key binding.+askBinding :: MonadClientUI m => m Binding+askBinding = getsSession sbinding++-- | Sync frames display with the frontend.+syncFrames :: MonadClientUI m => m ()+syncFrames = do+  -- Hack.+  writeConnFrontend FrontSlides{frontClear=[], frontSlides=[]}+  km <- readConnFrontend+  assert (km == K.spaceKM) skip++tryTakeMVarSescMVar :: MonadClientUI m => m Bool+tryTakeMVarSescMVar = do+  mescMVar <- getsSession sescMVar+  case mescMVar of+    Nothing -> return False+    Just escMVar -> do+      mUnit <- liftIO $ tryTakeMVar escMVar+      return $ isJust mUnit++scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow+scoreToSlideshow total status = do+  cops <- getsState scops+  fid <- getsClient sside+  fact <- getsState $ (EM.! fid) . sfactionD+  -- TODO: Re-read the table in case it's changed by a concurrent game.+  -- 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+  time <- getsState stime+  date <- liftIO getClockTime+  scurDifficulty <- getsClient scurDifficulty+  factionD <- getsState sfactionD+  fightsSpawners <- fightsAgainstSpawners fid+  let showScore (ntable, pos) = HighScore.highSlideshow ntable pos+      diff | not $ playerUI $ gplayer fact = difficultyDefault+           | otherwise = scurDifficulty+      theirVic (fi, fa) | isAtWar fact fi+                          && not (isHorrorFact cops fa) = Just $ gvictims fa+                        | otherwise = Nothing+      theirVictims = EM.unionsWith (+) $ mapMaybe theirVic $ EM.assocs factionD+      ourVic (fi, fa) | isAllied fact fi || fi == fid = Just $ gvictims fa+                      | otherwise = Nothing+      ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD+      (worthMentioning, rScore) =+        HighScore.register table total time status date diff+                           (playerName $ gplayer fact)+                           ourVictims theirVictims fightsSpawners+  return $! if worthMentioning then showScore rScore else mempty++getLeaderUI :: MonadClientUI m => m ActorId+getLeaderUI = do+  cli <- getClient+  case _sleader cli of+    Nothing -> assert `failure` "leader expected but not found" `twith` cli+    Just leader -> return leader++getArenaUI :: MonadClientUI m => m LevelId+getArenaUI = do+  mleader <- getsClient _sleader+  case mleader of+    Just leader -> getsState $ blid . getActorBody leader+    Nothing -> do+      side <- getsClient sside+      fact <- getsState $ (EM.! side) . sfactionD+      case gquit fact of+        Just Status{stDepth} -> return $! toEnum stDepth+        Nothing -> do+          dungeon <- getsState sdungeon+          let (minD, maxD) =+                case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of+                  (Just ((s, _), _), Just ((e, _), _)) -> (s, e)+                  _ -> assert `failure` "empty dungeon" `twith` dungeon+          return $! max minD $ min maxD $ toEnum $ playerEntry $ gplayer fact++viewedLevel :: MonadClientUI m => m LevelId+viewedLevel = do+  arena <- getArenaUI+  stgtMode <- getsClient stgtMode+  return $! maybe arena tgtLevelId stgtMode++targetDesc :: MonadClientUI m => Maybe Target -> m (Text, Maybe Text)+targetDesc target = do+  lidV <- viewedLevel+  mleader <- getsClient _sleader+  case target of+    Just (TEnemy aid _) -> do+      side <- getsClient sside+      b <- getsState $ getActorBody aid+      maxHP <- sumOrganEqpClient Effect.EqpSlotAddMaxHP aid+      let percentage = 100 * bhp b `div` xM (max 5 maxHP)+          stars | percentage < 20  = "[_____]"+                | percentage < 40  = "[*____]"+                | percentage < 60  = "[**___]"+                | percentage < 80  = "[***__]"+                | percentage < 100 = "[****_]"+                | otherwise        = "[*****]"+          hpIndicator = if bfid b == side then Nothing else Just stars+      return (bname b, hpIndicator)+    Just (TEnemyPos _ lid p _) -> do+      let hotText = if lid == lidV+                    then "hot spot" <+> (T.pack . show) p+                    else "a hot spot on level" <+> tshow (abs $ fromEnum lid)+      return (hotText, Nothing)+    Just (TPoint lid p) -> do+      pointedText <-+        if lid == lidV+        then do+          lvl <- getLevel lid+          case EM.assocs $ lvl `atI` p of+            [] -> return $! "exact spot" <+> (T.pack . show) p+            [(iid, k)] -> do+              itemToF <- itemToFullClient+              let (name, stats) = partItem CGround (itemToF iid k)+              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+        else return $! "an exact spot on level" <+> tshow (abs $ fromEnum lid)+      return (pointedText, Nothing)+    Just TVector{} ->+      case mleader of+        Nothing -> return ("a relative shift", Nothing)+        Just aid -> do+          tgtPos <- aidTgtToPos aid lidV target+          let invalidMsg = "an invalid relative shift"+              validMsg p = "shift to" <+> (T.pack . show) p+          return (maybe invalidMsg validMsg tgtPos, Nothing)+    Nothing -> return ("cursor location", Nothing)++targetDescLeader :: MonadClientUI m => ActorId -> m (Text, Maybe Text)+targetDescLeader leader = do+  tgt <- getsClient $ getTarget leader+  targetDesc tgt++targetDescCursor :: MonadClientUI m => m (Text, Maybe Text)+targetDescCursor = do+  scursor <- getsClient scursor+  targetDesc $ Just scursor++leaderTgtToPos :: MonadClientUI m => m (Maybe Point)+leaderTgtToPos = do+  lidV <- viewedLevel+  mleader <- getsClient _sleader+  case mleader of+    Nothing -> return Nothing+    Just aid -> do+      tgt <- getsClient $ getTarget aid+      aidTgtToPos aid lidV tgt++leaderTgtAims :: MonadClientUI m => m (Either Text Int)+leaderTgtAims = do+  lidV <- viewedLevel+  mleader <- getsClient _sleader+  case mleader of+    Nothing -> return $ Left "no leader to target with"+    Just aid -> do+      tgt <- getsClient $ getTarget aid+      aidTgtAims aid lidV tgt++cursorToPos :: MonadClientUI m => m (Maybe Point)+cursorToPos = do+  lidV <- viewedLevel+  mleader <- getsClient _sleader+  scursor <- getsClient scursor+  case mleader of+    Nothing -> return Nothing+    Just aid -> aidTgtToPos aid lidV $ Just scursor
+ Game/LambdaHack/Client/UI/MsgClient.hs view
@@ -0,0 +1,138 @@+-- | Client monad for interacting with a human through UI.+module Game.LambdaHack.Client.UI.MsgClient+  ( msgAdd, msgReset, recordHistory+  , SlideOrCmd, failWith, failSlides, failSer+  , lookAt, itemOverlay+  ) where++import Control.Arrow (first)+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)+import qualified Data.Text as T+import qualified Game.LambdaHack.Common.Kind as Kind+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Client.CommonClient+import Game.LambdaHack.Client.ItemSlot+import Game.LambdaHack.Client.MonadClient hiding (liftIO)+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.Config+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Client.UI.WidgetClient+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemDescription+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 Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Content.TileKind++-- | Add a message to the current report.+msgAdd :: MonadClientUI m => Msg -> m ()+msgAdd msg = modifyClient $ \d -> d {sreport = addMsg (sreport d) msg}++-- | Wipe out and set a new value for the current report.+msgReset :: MonadClientUI m => Msg -> m ()+msgReset msg = modifyClient $ \d -> d {sreport = singletonReport msg}++-- | Store current report in the history and reset report.+recordHistory :: MonadClientUI m => m ()+recordHistory = do+  StateClient{sreport, shistory} <- getClient+  unless (nullReport sreport) $ do+    Config{configHistoryMax} <- askConfig+    msgReset ""+    let nhistory = takeHistory configHistoryMax $! addReport sreport shistory+    modifyClient $ \cli -> cli {shistory = nhistory}++type SlideOrCmd a = Either Slideshow a++failWith :: MonadClientUI m => Msg -> m (SlideOrCmd a)+failWith msg = do+  stopPlayBack+  assert (not $ T.null msg) $ fmap Left $ promptToSlideshow msg++failSlides :: MonadClientUI m => Slideshow -> m (SlideOrCmd a)+failSlides slides = do+  stopPlayBack+  return $ Left slides++failSer :: MonadClientUI m => ReqFailure -> m (SlideOrCmd a)+failSer = failWith . showReqFailure++-- | Produces a textual description of the terrain and items at an already+-- explored position. Mute for unknown positions.+-- The detailed variant is for use in the targeting mode.+lookAt :: MonadClientUI m+       => Bool       -- ^ detailed?+       -> Text       -- ^ how to start tile description+       -> Bool       -- ^ can be seen right now?+       -> Point      -- ^ position to describe+       -> ActorId    -- ^ the actor that looks+       -> Text       -- ^ an extra sentence to print+       -> m Text+lookAt detailed tilePrefix canSee pos aid msg = do+  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops+  itemToF <- itemToFullClient+  lidV <- viewedLevel+  lvl <- getLevel lidV+  b <- getsState $ getActorBody aid+  subject <- partAidLeader aid+  let is = lvl `atI` pos+      verb = MU.Text $ if pos == bpos b+                       then "stand on"+                       else if canSee then "notice" else "remember"+  let nWs (iid, k) = partItemWs k CGround (itemToF iid k)+      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."+      tile = lvl `at` pos+      obscured | knownLsecret lvl+                 && tile /= hideTile cotile lvl pos = "partially obscured"+               | otherwise = ""+      tileText = obscured <+> tname (okind tile)+      tilePart | T.null tilePrefix = MU.Text tileText+               | otherwise = MU.AW $ MU.Text tileText+      tileDesc = [MU.Text tilePrefix, tilePart]+  if not (null (Tile.causeEffects cotile tile)) then+    return $! makeSentence ("activable:" : tileDesc)+              <+> msg <+> isd+  else if detailed then+    return $! makeSentence tileDesc+              <+> msg <+> isd+  else return $! msg <+> isd++-- | Create a list of item names.+itemOverlay :: MonadClient m => CStore -> ItemBag -> m Overlay+itemOverlay cstore bag = do+  itemToF <- itemToFullClient+  (letterSlots, numberSlots) <- getsClient sslots+  let pr (l, iid) =+        case EM.lookup iid bag of+          Nothing -> Nothing+          Just k ->+            let itemFull = itemToF iid k+                -- TODO: add color item symbols as soon as we have a menu+                -- with all items visible on the floor or known to player+                -- symbol = jsymbol $ itemBase itemFull+            in Just $ makePhrase [ slotLabel l, "-"  -- MU.String [symbol]+                                 , partItemWs k cstore itemFull ]+                           <> " "+  return $! toOverlay $ mapMaybe pr+    $ map (first Left) (EM.assocs letterSlots)+      ++ (map (first Right) (IM.assocs numberSlots))
+ Game/LambdaHack/Client/UI/RunClient.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE RankNTypes #-}+-- | Running and disturbance.+--+-- The general rule is: whatever is behind you (and so ignored previously),+-- determines what you ignore moving forward. This is calcaulated+-- separately for the tiles to the left, to the right and in the middle+-- along the running direction. So, if you want to ignore something+-- start running when you stand on it (or to the right or left, respectively)+-- or by entering it (or passing to the right or left, respectively).+--+-- Some things are never ignored, such as: enemies seen, imporant messages+-- heard, solid tiles and actors in the way.+module Game.LambdaHack.Client.UI.RunClient+  ( continueRun, moveRunAid+  ) where++import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.ByteString.Char8 as BS+import qualified Data.EnumMap.Strict as EM+import Data.Function+import Data.List+import Data.Maybe++import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Msg+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.Vector+import Game.LambdaHack.Content.TileKind++-- | 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+      let runStopMsgCurrent =+            either Just (const Nothing) mdirOrRunStopMsgCurrent+          runStopMsgNew = runStopMsg `mplus` runStopMsgCurrent+          -- We check @runStopMsgNew@, because even if the current actor+          -- runs OK, we want to stop soon if some others had to stop.+          runMembersNew = if isJust runStopMsgNew then rs else rs ++ [r]+          paramNew = paramOld { runMembers = runMembersNew+                              , runDist = runDistNew+                              , runStopMsg = runStopMsgNew }+      case mdirOrRunStopMsgCurrent of+        Left _ -> continueRun paramNew  -- run all undisturbed; only one time+        Right dir -> do+          s <- getState+          modifyClient $ updateLeader r s+          return $ Right (paramNew, 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 not $ EM.null $ lvl `atI` tpos 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 it costs a turn+            -- and does not harm the invisible actors, so it's not tempting.+       -- Ignore a known boring, not accessible tile.+       else Left "never mind"+  return $! runStopOrCmd++-- | This function implements the actual logic of running. It checks if we+-- have to stop running because something interesting cropped up,+-- it ajusts the direction given by the vector if we reached+-- a corridor's corner (we never change direction except in corridors)+-- and it increments the counter of traversed tiles.+continueRunDir :: MonadClient m+               => ActorId -> Int -> Maybe Vector -> m (Either Msg Vector)+continueRunDir aid distLast mdir = do+  sreport <- getsClient sreport -- TODO: check the message before it goes into history+  let boringMsgs = map BS.pack [ "You hear some noises."+                               , "reveals that the" ]+      boring repLine = any (`BS.isInfixOf` repLine) boringMsgs+      -- TODO: use a regexp from the UI config instead+      msgShown  = isJust $ findInReport (not . boring) sreport+  if msgShown then return $ Left "message shown"+  else do+    let maxDistance = 20+    cops@Kind.COps{cotile} <- getsState scops+    body <- getsState $ getActorBody aid+    let lid = blid body+    lvl <- getLevel lid+    let posHere = bpos body+        posLast = boldpos body+        dirLast = 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++tryTurning :: MonadClient m+           => ActorId -> m (Either Msg Vector)+tryTurning aid = do+  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+  let openableDir dir = Tile.isOpenable cotile (lvl `at` (posHere `shift` dir))+      dirEnterable dir = accessibleDir cops lvl posHere dir || openableDir dir+      dirNearby dir1 dir2 = euclidDistSqVector dir1 dir2 `elem` [1, 2]+      dirSimilar dir = dirNearby dirLast dir && dirEnterable dir+      dirsSimilar = filter dirSimilar moves+  case dirsSimilar of+    [] -> return $ Left "dead end"+    d1 : ds | all (dirNearby d1) ds ->  -- only one or two directions possible+      case sortBy (compare `on` euclidDistSqVector dirLast)+           $ filter (accessibleDir cops lvl posHere) $ d1 : ds of+        [] ->+          return $ Left "blocked and all similar directions are closed doors"+        d : _ -> checkAndRun aid d+    _ -> return $ Left "blocked and many distant similar directions found"++-- The direction is different than the original, if called from @tryTurning@+-- and the same if from @continueRunDir@.+checkAndRun :: MonadClient m+            => ActorId -> Vector -> m (Either Msg Vector)+checkAndRun aid dir = do+  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops+  body <- getsState $ getActorBody aid+  smarkSuspect <- getsClient smarkSuspect+  let lid = blid body+  lvl <- getLevel lid+  let posHere = bpos body+      posHasItems pos = not $ EM.null $ lvl `atI` pos+      posThere = posHere `shift` dir+  actorsThere <- getsState $ posToActors posThere lid+  let posLast = boldpos body+      dirLast = posHere `vectorToFrom` posLast+      -- This is supposed to work on unit vectors --- diagonal, as well as,+      -- vertical and horizontal.+      anglePos :: Point -> Vector -> RadianAngle -> Point+      anglePos pos d angle = shift pos (rotate angle d)+      -- We assume the tiles have not changes since last running step.+      -- If they did, we don't care --- running should be stopped+      -- because of the change of nearby tiles then (TODO).+      -- We don't take into account the two tiles at the rear of last+      -- surroundings, because the actor may have come from there+      -- (via a diagonal move) and if so, he may be interested in such tiles.+      -- If he arrived directly from the right or left, he is responsible+      -- for starting the run further away, if he does not want to ignore+      -- such tiles as the ones he came from.+      tileLast = lvl `at` posLast+      tileHere = lvl `at` posHere+      tileThere = lvl `at` posThere+      leftPsLast = map (anglePos posHere dirLast) [pi/2, 3*pi/4]+                   ++ map (anglePos posHere dir) [pi/2, 3*pi/4]+      rightPsLast = map (anglePos posHere dirLast) [-pi/2, -3*pi/4]+                    ++ map (anglePos posHere dir) [-pi/2, -3*pi/4]+      leftForwardPosHere = anglePos posHere dir (pi/4)+      rightForwardPosHere = anglePos posHere dir (-pi/4)+      leftTilesLast = map (lvl `at`) leftPsLast+      rightTilesLast = map (lvl `at`) rightPsLast+      leftForwardTileHere = lvl `at` leftForwardPosHere+      rightForwardTileHere = lvl `at` rightForwardPosHere+      featAt = actionFeatures smarkSuspect . okind+      terrainChangeMiddle = null (Tile.causeEffects cotile tileThere)+                              -- step into; will stop next turn due to message+                            && featAt tileThere+                               `notElem` map featAt [tileLast, tileHere]+      terrainChangeLeft = featAt leftForwardTileHere+                          `notElem` map featAt leftTilesLast+      terrainChangeRight = featAt rightForwardTileHere+                           `notElem` map featAt rightTilesLast+      itemChangeLeft = posHasItems leftForwardPosHere+                       `notElem` map posHasItems leftPsLast+      itemChangeRight = posHasItems rightForwardPosHere+                        `notElem` map posHasItems rightPsLast+      check+        | not $ null actorsThere = return $ Left "actor in the way"+                       -- Actor in possibly another direction tnat original.+        | terrainChangeLeft = return $ Left "terrain change on the left"+        | terrainChangeRight = return $ Left "terrain change on the right"+        | itemChangeLeft = return $ Left "item change on the left"+        | itemChangeRight = return $ Left "item change on the right"+        | terrainChangeMiddle = return $ Left "terrain change in the middle"+        | otherwise = return $ Right dir+  check
+ Game/LambdaHack/Client/UI/StartupFrontendClient.hs view
@@ -0,0 +1,65 @@+-- | Startup up the frontend together with the server, which starts up clients.+module Game.LambdaHack.Client.UI.StartupFrontendClient+  ( srtFrontend+  ) where++import Control.Concurrent.Async+import qualified Control.Concurrent.STM as STM+import Control.Exception.Assert.Sugar++import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.Config+import Game.LambdaHack.Client.UI.Content.KeyKind+import Game.LambdaHack.Client.UI.Frontend+import Game.LambdaHack.Client.UI.KeyBindings+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Msg+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.+srtFrontend :: (DebugModeCli -> SessionUI -> State -> StateClient+                -> chanServerUI+                -> IO ())+            -> (DebugModeCli -> SessionUI -> State -> StateClient+                -> chanServerAI+                -> IO ())+            -> KeyKind -> Kind.COps -> DebugModeCli+            -> ((FactionId -> chanServerUI -> IO ())+               -> (FactionId -> chanServerAI -> IO ())+               -> IO ())+            -> IO ()+srtFrontend executorUI executorAI+            copsClient cops@Kind.COps{corule} sdebugCli exeServer = do+  -- UI config reloaded at each client start.+  sconfig <- mkConfig corule+  let !sbinding = stdBinding copsClient sconfig  -- evaluate to check for errors+      sdebugMode = applyConfigToDebug sconfig sdebugCli corule+  defaultHist <- defaultHistory+  let cli = defStateClient defaultHist emptyReport+      s = updateCOps (const cops) emptyState+      exeClientAI fid =+        let noSession = assert `failure` "AI client needs no UI session"+                               `twith` fid+        in executorAI sdebugMode noSession s (cli fid True)+      exeClientUI sescMVar loopFrontend fid chanServerUI = do+        responseF <- STM.newTQueueIO+        requestF <- STM.newTQueueIO+        let schanF = ChanFrontend{..}+        a <- async $ loopFrontend schanF+        link a+        executorUI sdebugMode SessionUI{..} s (cli fid False) chanServerUI+        STM.atomically $ STM.writeTQueue requestF FrontFinish+        wait a+  -- TODO: let each client start his own raw frontend (e.g., gtk, though+  -- that leads to disaster); then don't give server as the argument+  -- to startupF, but the Client.hs (when it ends, gtk ends); server is+  -- then forked separately and client doesn't need to know about+  -- starting servers.+  startupF sdebugMode $ \sescMVar loopFrontend ->+    exeServer (exeClientUI sescMVar loopFrontend) exeClientAI
+ Game/LambdaHack/Client/UI/WidgetClient.hs view
@@ -0,0 +1,156 @@+-- | A set of widgets for UI clients.+module Game.LambdaHack.Client.UI.WidgetClient+  ( displayMore, displayYesNo, displayChoiceUI, displayPush, displayPushIfLid+  , promptToSlideshow, overlayToSlideshow, overlayToBlankSlideshow+  , animate, fadeOutOrIn+  ) where++import Control.Monad+import qualified Data.EnumMap.Strict as EM+import Data.Maybe+import Data.Monoid++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.DrawClient+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.ModeKind++-- | 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}+             , K.escKM+             ]+  K.KM {key} <- promptGetKey keys frame+  case key of+    K.Char 'y' -> return True+    _          -> return False++-- | Display a message with a @-more-@ prompt.+-- Return value indicates if the player tried to cancel/escape.+displayMore :: MonadClientUI m => ColorMode -> Msg -> m Bool+displayMore dm prompt = do+  slides <- promptToSlideshow $ prompt <+> moreMsg+  -- Two frames drawn total (unless 'prompt' very long).+  getInitConfirms dm [] $ slides <> toSlideshow False [[]]++-- | Print a yes/no question and return the player's answer. Use black+-- and white colours to turn player's attention to the choice.+displayYesNo :: MonadClientUI m => ColorMode -> Msg -> m Bool+displayYesNo dm prompt = do+  sli <- promptToSlideshow $ prompt <+> yesnoMsg+  frame <- drawOverlay False dm $ head . snd $ slideshow sli+  getYesNo frame++-- TODO: generalize getInitConfirms and displayChoiceUI to a single op+-- | Print a prompt and an overlay and wait for a player keypress.+-- If many overlays, scroll screenfuls with SPACE. Do not wrap screenfuls+-- (in some menus @?@ cycles views, so the user can restart from the top).+displayChoiceUI :: 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++-- 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 ""+  let slide = head . snd $ slideshow sls+      underAI = playerAI $ gplayer 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)++displayPushIfLid :: MonadClientUI m => LevelId -> m ()+displayPushIfLid lid = do+  arena <- getArenaUI+  when (arena == lid) displayPush++-- | The prompt is shown after the current message, but not added to history.+-- This is useful, e.g., in targeting mode, not to spam history.+promptToSlideshow :: MonadClientUI m => Msg -> m Slideshow+promptToSlideshow prompt = overlayToSlideshow prompt emptyOverlay++-- | The prompt is shown after the current message at the top of each slide.+-- Together they may take more than one line. The prompt is not added+-- to history. The portions of overlay that fit on the the rest+-- of the screen are displayed below. As many slides as needed are shown.+overlayToSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow+overlayToSlideshow prompt overlay = do+  lid <- getArenaUI+  Level{lxsize, lysize} <- getLevel lid  -- TODO: screen length or viewLevel+  sreport <- getsClient sreport+  let msg = splitReport lxsize (addMsg sreport prompt)+  return $! splitOverlay False (lysize + 1) msg overlay++overlayToBlankSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow+overlayToBlankSlideshow prompt overlay = do+  lid <- getArenaUI+  Level{lysize} <- getLevel lid  -- TODO: screen length or viewLevel+  return $! splitOverlay True (lysize + 3) (toOverlay [prompt]) overlay++-- TODO: restrict the animation to 'per' before drawing.+-- | Render animations on top of the current screen frame.+animate :: MonadClientUI m => LevelId -> Animation -> m Frames+animate arena anim = do+  sreport <- getsClient sreport+  mleader <- getsClient _sleader+  Level{lxsize, lysize} <- getLevel arena+  tgtPos <- leaderTgtToPos+  cursorPos <- cursorToPos+  let anyPos = fromMaybe (Point 0 0) cursorPos+      pathFromLeader leader = fmap Just $ getCacheBfsAndPath leader anyPos+  bfsmpath <- maybe (return Nothing) pathFromLeader mleader+  tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader+  cursorDesc <- targetDescCursor+  let over = renderReport sreport+      topLineOnly = truncateToOverlay over+  basicFrame <-+    draw False ColorFull arena cursorPos tgtPos+         bfsmpath cursorDesc tgtDesc topLineOnly+  snoAnim <- getsClient $ snoAnim . sdebugCli+  return $! if fromMaybe False snoAnim+            then [Just basicFrame]+            else renderAnim lxsize lysize basicFrame anim++fadeOutOrIn :: MonadClientUI m => Bool -> m ()+fadeOutOrIn out = do+  let topRight = True+  lid <- getArenaUI+  Level{lxsize, lysize} <- getLevel lid+  animMap <- rndToAction $ fadeout out topRight 2 lxsize lysize+  animFrs <- animate lid animMap+  displayFrames animFrs
Game/LambdaHack/Common/Ability.hs view
@@ -1,28 +1,55 @@+{-# LANGUAGE DeriveGeneric #-} -- | AI strategy abilities. module Game.LambdaHack.Common.Ability-  ( Ability(..)+  ( Ability(..), Skills, zeroSkills, unitSkills, addSkills, scaleSkills   ) where  import Data.Binary+import qualified Data.EnumMap.Strict as EM+import Data.Hashable (Hashable)+import GHC.Generics (Generic) --- | All possible AI actor abilities. AI chooses among these when considering--- the next action to perform. The ability descriptions refer to the target--- that any actor picks each turn, depending on the actor's characteristics--- and his environment.+-- | Actor and faction abilities corresponding to client-server requests. data Ability =-    Track   -- ^ move along a set trajectory, if any, meleeing any opponents-  | Heal    -- ^ heal if almost dead-  | Flee    -- ^ flee if almost dead-  | Melee   -- ^ melee target-  | Displace  -- ^ switch places with a friend-  | Pickup  -- ^ gather items, if no foes visible-  | Trigger -- ^ trigger a feature-  | Ranged  -- ^ attack the visible target opponent at range, some of the time-  | Tools   -- ^ use items, if target opponent visible, some of the time-  | Chase   -- ^ chase the target, ignoring any actors on the way-  | Wander  -- ^ wander around, meleeing any opponents on the way-  deriving (Show, Eq, Ord, Enum, Bounded)+    AbMove+  | AbMelee+  | AbDisplace+  | AbAlter+  | AbWait+  | AbMoveItem+  | AbProject+  | AbApply+  | AbTrigger+  deriving (Read, Eq, Ord, Generic, Enum, Bounded) +-- skill level in particular abilities.+type Skills = EM.EnumMap Ability Int++zeroSkills :: Skills+zeroSkills = EM.fromDistinctAscList $ zip [minBound..maxBound] (repeat 0)++unitSkills :: Skills+unitSkills = EM.fromDistinctAscList $ zip [minBound..maxBound] (repeat 1)++addSkills :: Skills -> Skills -> Skills+addSkills = EM.unionWith (+)++scaleSkills :: Int -> Skills -> Skills+scaleSkills n = EM.map (n *)++instance Show Ability where+  show AbMove = "move"+  show AbMelee = "melee"+  show AbDisplace = "displace"+  show AbAlter = "alter tile"+  show AbWait = "wait"+  show AbMoveItem = "manage items"+  show AbProject = "fling"+  show AbApply = "activate"+  show AbTrigger = "trigger tile"+ instance Binary Ability where   put = putWord8 . toEnum . fromEnum   get = fmap (toEnum . fromEnum) getWord8++instance Hashable Ability
− Game/LambdaHack/Common/Action.hs 
@@ -1,45 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | Game action monads and basic building blocks for human and computer--- player actions. Has no access to the the main action type.-module Game.LambdaHack.Common.Action-  ( -- * Action monads-    MonadActionRO(..), MonadAction(..), MonadAtomic(..)-    -- * Shorthands-  , getLevel, nUI-    -- * Assorted-  , serverSaveName-  ) where--import qualified Data.EnumMap.Strict as EM--import Game.LambdaHack.Common.AtomicCmd-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind--class (Monad m, Functor m) => MonadActionRO m where-  getState    :: m State-  getsState   :: (State -> a) -> m a--class MonadActionRO m => MonadAction m where-  modifyState :: (State -> State) -> m ()-  putState    :: State -> m ()--class MonadActionRO m => MonadAtomic m where-  execAtomic    :: Atomic -> m ()-  execCmdAtomic :: CmdAtomic -> m ()-  execCmdAtomic = execAtomic . CmdAtomic-  execSfxAtomic :: SfxAtomic -> m ()-  execSfxAtomic = execAtomic . SfxAtomic--getLevel :: MonadActionRO m => LevelId -> m Level-getLevel lid = getsState $ (EM.! lid) . sdungeon--nUI :: MonadActionRO m => m Int-nUI = do-  factionD <- getsState sfactionD-  return $! length $ filter (playerUI . gplayer) $ EM.elems factionD--serverSaveName :: String-serverSaveName = "server.sav"
Game/LambdaHack/Common/Actor.hs view
@@ -3,118 +3,149 @@ -- involves the 'State' or 'Action' type. module Game.LambdaHack.Common.Actor   ( -- * Actor identifiers and related operations-    ActorId, monsterGenChance, partActor+    ActorId, monsterGenChance, partActor, partPronoun     -- * The@ Acto@r type-  , Actor(..), actorTemplate, timeAddFromSpeed, braced, waitedLastTurn-  , unoccupied, heroKindId, projectileKindId-    -- * Inventory management-  , ItemBag, ItemInv, InvChar(..), ItemDict, ItemRev-  , allLetters, assignLetter, letterLabel, letterRange, rmFromBag+  , Actor(..), ResDelta(..)+  , deltaSerious, deltaMild, xM, minusM, minusTwoM, oneM+  , bspeed, actorTemplate, timeShiftFromSpeed, braced, waitedLastTurn+  , actorDying, actorNewBorn, hpTooLow, unoccupied     -- * Assorted-  , ActorDict, smellTimeout, mapActorItems_, checkAdjacent+  , ActorDict, smellTimeout, checkAdjacent+  , mapActorItems_, ppCStore, ppContainer   ) where  import Control.Exception.Assert.Sugar import Data.Binary-import Data.Char 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.Maybe+import Data.Int (Int64) import Data.Ratio import Data.Text (Text)-import qualified Data.Text as T-import Data.Tuple import qualified NLP.Miniutter.English as MU  import qualified Game.LambdaHack.Common.Color as Color+import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind+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 import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ActorKind --- | A unique identifier of an actor in the dungeon.-newtype ActorId = ActorId Int-  deriving (Show, Eq, Ord, Enum)--instance Binary ActorId where-  put (ActorId n) = put n-  get = fmap ActorId get- -- | Actor properties that are changing throughout the game. -- If they are dublets of properties from @ActorKind@, -- they are usually modified temporarily, but tend to return -- to the original value from @ActorKind@ over time. E.g., HP. data Actor = Actor-  { bkind       :: !(Kind.Id ActorKind)  -- ^ the kind of the actor+  { -- The trunk of the actor's body (present also in @borgan@ or @beqp@)+    btrunk      :: !ItemId+    -- Presentation   , bsymbol     :: !Char                 -- ^ individual map symbol   , bname       :: !Text                 -- ^ individual name+  , bpronoun    :: !Text                 -- ^ individual pronoun   , bcolor      :: !Color.Color          -- ^ individual map color-  , bspeed      :: !Speed                -- ^ individual speed-  , bhp         :: !Int                  -- ^ current hit points-  , btrajectory :: !(Maybe [Vector])     -- ^ trajectory the actor must travel+    -- 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+    -- Location   , bpos        :: !Point                -- ^ current position   , boldpos     :: !Point                -- ^ previous position   , blid        :: !LevelId              -- ^ current level   , boldlid     :: !LevelId              -- ^ previous level-  , bbag        :: !ItemBag              -- ^ items carried-  , binv        :: !ItemInv              -- ^ map from letters to items-  , bletter     :: !InvChar              -- ^ next inventory letter-  , btime       :: !Time                 -- ^ absolute time of next action-  , bwait       :: !Bool                 -- ^ is the actor waiting right now?   , bfid        :: !FactionId            -- ^ faction the actor belongs to+  , boldfid     :: !FactionId            -- ^ previous 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+    -- Assorted+  , bwait       :: !Bool                 -- ^ is the actor waiting right now?   , bproj       :: !Bool                 -- ^ is a projectile? (shorthand only,                                          --   this can be deduced from bkind)   }-  deriving (Show, Eq, Ord)+  deriving (Show, Eq) +data ResDelta = ResDelta+  { resCurrentTurn  :: !Int64  -- ^ resource change this player turn+  , resPreviousTurn :: !Int64  -- ^ resource change last player turn+  }+  deriving (Show, Eq)++deltaSerious :: ResDelta -> Bool+deltaSerious ResDelta{..} = resCurrentTurn < minusM || resPreviousTurn < minusM++deltaMild :: ResDelta -> Bool+deltaMild ResDelta{..} = resCurrentTurn == minusM || resPreviousTurn == minusM++xM :: Int -> Int64+xM k = fromIntegral k * 1000000++minusM, minusTwoM, oneM :: Int64+minusM = xM (-1)+minusTwoM = xM (-2)+oneM = xM 1+ -- | Chance that a new monster is generated. Currently depends on the -- number of monsters already present, and on the level. In the future, -- the strength of the character and the strength of the monsters present -- could further influence the chance, and the chance could also affect -- which monster is generated. How many and which monsters are generated -- will also depend on the cave kind used to build the level.-monsterGenChance :: Int -> Int -> Int -> Rnd Bool-monsterGenChance n' depth' numMonsters =-  -- Mimics @castDeep@.-  let n = abs n'-      depth = abs depth'-      -- On level 1, First 2 monsters appear fast.-      scaledDepth = 5 * n `div` depth-  in chance $ 1%(fromIntegral (100 * (numMonsters - scaledDepth)) `max` 10)+monsterGenChance :: AbsDepth -> AbsDepth -> Int -> Rnd Bool+monsterGenChance (AbsDepth n) (AbsDepth depth) numMonsters =+  assert (depth > 0)+  -- Mimics @castDice@. On level 1, First 2 monsters appear fast.+  $ let scaledDepth = 5 * n `div` depth+    in chance $ 1%(fromIntegral (300 * (numMonsters - scaledDepth)) `max` 20)  -- | The part of speech describing the actor. partActor :: Actor -> MU.Part partActor b = MU.Text $ bname b +-- | The part of speech containing the actor pronoun.+partPronoun :: Actor -> MU.Part+partPronoun b = MU.Text $ bpronoun b+ -- Actor operations  -- | A template for a new actor.-actorTemplate :: Kind.Id ActorKind -> Char -> Text-              -> Color.Color -> Speed -> Int -> Maybe [Vector]-              -> Point -> LevelId -> Time -> FactionId -> Bool -> Actor-actorTemplate bkind bsymbol bname bcolor bspeed bhp btrajectory bpos blid btime-              bfid bproj =-  let boldpos = Point 0 0  -- make sure /= bpos, to tell it didn't switch level+actorTemplate :: ItemId -> Char -> Text -> Text+              -> Color.Color -> Int64 -> Int64+              -> Point -> LevelId -> Time -> FactionId+              -> Actor+actorTemplate btrunk bsymbol bname bpronoun bcolor bhp bcalm+              bpos blid btime bfid =+  let btrajectory = Nothing+      boldpos = Point 0 0  -- make sure /= bpos, to tell it didn't switch level       boldlid = blid-      bbag    = EM.empty+      beqp    = EM.empty       binv    = EM.empty-      bletter = InvChar 'a'+      borgan  = EM.empty       bwait   = False+      boldfid = bfid+      bhpDelta = ResDelta 0 0+      bcalmDelta = ResDelta 0 0+      bproj = False   in Actor{..} +bspeed :: Actor -> [ItemFull] -> Speed+bspeed b activeItems =+  case btrajectory b of+    Nothing -> toSpeed $ max 1  -- avoid infinite wait+               $ sumSlotNoFilter Effect.EqpSlotAddSpeed activeItems+    Just (_, speed) -> speed+ -- | Add time taken by a single step at the actor's current speed.-timeAddFromSpeed :: Actor -> Time -> Time-timeAddFromSpeed b time =-  let speed = bspeed b+timeShiftFromSpeed :: Actor -> [ItemFull] -> Time -> Time+timeShiftFromSpeed b activeItems time =+  let speed = bspeed b activeItems       delta = ticksPerMeter speed-  in timeAdd time delta+  in timeShift time delta  -- | Whether an actor is braced for combat this clip. braced :: Actor -> Bool@@ -124,149 +155,108 @@ waitedLastTurn :: Actor -> Bool waitedLastTurn b = bwait b +actorDying :: Actor -> Bool+actorDying b = if bproj b+               then bhp b < 0+                    || maybe True (null . fst) (btrajectory b)+               else bhp b <= 0++actorNewBorn :: Actor -> Bool+actorNewBorn b = boldpos b == Point 0 0+                 && not (waitedLastTurn b)+                 && not (btime b < timeTurn)++hpTooLow :: Actor -> [ItemFull] -> Bool+hpTooLow b activeItems =+  let maxHP = sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems+  in bhp b <= oneM || 5 * bhp b < xM maxHP+ -- | Checks for the presence of actors in a position. -- Does not check if the tile is walkable. unoccupied :: [Actor] -> Point -> Bool unoccupied actors pos = all (\b -> bpos b /= pos) actors --- | The unique kind of heroes.-heroKindId :: Kind.Ops ActorKind -> Kind.Id ActorKind-heroKindId Kind.Ops{ouniqGroup} = ouniqGroup "hero"---- | The unique kind of projectiles.-projectileKindId :: Kind.Ops ActorKind -> Kind.Id ActorKind-projectileKindId Kind.Ops{ouniqGroup} = ouniqGroup "projectile"- -- | How long until an actor's smell vanishes from a tile.-smellTimeout :: Time-smellTimeout = timeScale timeTurn 100--newtype InvChar = InvChar {invChar :: Char}-  deriving (Show, Eq, Enum)--instance Ord InvChar where-  compare (InvChar x) (InvChar y) =-    compare (isUpper x, toLower x) (isUpper y, toLower y)--instance Binary InvChar where-  put (InvChar x) = put x-  get = fmap InvChar get--type ItemBag = EM.EnumMap ItemId Int--type ItemInv = EM.EnumMap InvChar ItemId---- | All items in the dungeon (including in actor inventories),--- indexed by item identifier.-type ItemDict = EM.EnumMap ItemId Item+smellTimeout :: Delta Time+smellTimeout = timeDeltaScale (Delta timeTurn) 100  -- | All actors on the level, indexed by actor identifier. type ActorDict = EM.EnumMap ActorId Actor --- | Reverse item map, for item creation, to keep items and item identifiers--- in bijection.-type ItemRev = HM.HashMap Item ItemId--cmpLetter :: InvChar -> InvChar -> Ordering-cmpLetter (InvChar x) (InvChar y) =-  compare (isUpper x, toLower x) (isUpper y, toLower y)--allLetters :: [InvChar]-allLetters = map InvChar $ ['a'..'z'] ++ ['A'..'Z']---- | Assigns a letter to an item, for inclusion in the inventory--- of a hero. Tries to to use the requested letter, if any.-assignLetter :: ItemId -> Maybe InvChar -> Actor -> Maybe InvChar-assignLetter iid r body =-  case lookup iid $ map swap $ EM.assocs $ binv body of-    Just l -> Just l-    Nothing ->  case r of-      Just l | l `elem` allowed -> Just l-      _ -> listToMaybe free- where-  c = bletter body-  candidates = take (length allLetters)-               $ drop (fromJust (elemIndex c allLetters))-               $ cycle allLetters-  inBag = EM.keysSet $ bbag body-  f l = maybe True (`ES.notMember` inBag) $ EM.lookup l $ binv body-  free = filter f candidates-  allowed = InvChar '$' : free--letterRange :: [InvChar] -> Text-letterRange ls =-  sectionBy (sortBy cmpLetter ls) Nothing- where-  succLetter c d = ord (invChar d) - ord (invChar c) == 1--  sectionBy []     Nothing       = T.empty-  sectionBy []     (Just (c, d)) = finish (c,d)-  sectionBy (x:xs) Nothing       = sectionBy xs (Just (x, x))-  sectionBy (x:xs) (Just (c, d))-    | succLetter d x             = sectionBy xs (Just (c, x))-    | otherwise                  = finish (c,d) <> sectionBy xs (Just (x, x))--  finish (c, d) | c == d         = T.pack [invChar c]-                | succLetter c d = T.pack [invChar c, invChar d]-                | otherwise      = T.pack [invChar c, '-', invChar d]--letterLabel :: InvChar -> MU.Part-letterLabel c = MU.Text $ T.pack $ invChar c : " -"--rmFromBag :: Int -> ItemId -> ItemBag -> ItemBag-rmFromBag k iid bag =-  let rib Nothing = assert `failure` "rm from empty bag" `twith` (k, iid, bag)-      rib (Just n) = case compare n k of-        LT -> assert `failure` "rm more than there is" `twith` (n, k, iid, bag)-        EQ -> Nothing-        GT -> Just (n - k)-  in EM.alter rib iid bag+checkAdjacent :: Actor -> Actor -> Bool+checkAdjacent sb tb = blid sb == blid tb && adjacent (bpos sb) (bpos tb)  mapActorItems_ :: Monad m => (ItemId -> Int -> m a) -> Actor -> m ()-mapActorItems_ f Actor{bbag} = do-  let is = EM.assocs bbag+mapActorItems_ f Actor{binv, beqp, borgan} = do+  let is = EM.assocs beqp ++ EM.assocs binv ++ EM.assocs borgan   mapM_ (uncurry f) is -checkAdjacent :: Actor -> Actor -> Bool-checkAdjacent sb tb = blid sb == blid tb && adjacent (bpos sb) (bpos tb)+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" +ppContainer :: Container -> Text+ppContainer CFloor{} = "nearby"+ppContainer (CActor _ cstore) = ppCStore cstore+ppContainer CTrunk{} = "in our possession"+ instance Binary Actor where   put Actor{..} = do-    put bkind+    put btrunk     put bsymbol     put bname+    put bpronoun     put bcolor-    put bspeed     put bhp+    put bhpDelta+    put bcalm+    put bcalmDelta     put btrajectory     put bpos     put boldpos     put blid     put boldlid-    put bbag     put binv-    put bletter+    put beqp+    put borgan     put btime     put bwait     put bfid+    put boldfid     put bproj   get = do-    bkind <- get+    btrunk <- get     bsymbol <- get     bname <- get+    bpronoun <- get     bcolor <- get-    bspeed <- get     bhp <- get+    bhpDelta <- get+    bcalm <- get+    bcalmDelta <- get     btrajectory <- get     bpos <- get     boldpos <- get     blid <- get     boldlid <- get-    bbag <- get     binv <- get-    bletter <- get+    beqp <- get+    borgan <- get     btime <- get     bwait <- get     bfid <- get+    boldfid <- get     bproj <- get     return $! Actor{..}++instance Binary ResDelta where+  put ResDelta{..} = do+    put resCurrentTurn+    put resPreviousTurn+  get = do+    resCurrentTurn <- get+    resPreviousTurn <- get+    return $! ResDelta{..}
Game/LambdaHack/Common/ActorState.hs view
@@ -2,40 +2,58 @@ -- but not the 'Action' type. -- TODO: Document an export list after it's rewritten according to #17. module Game.LambdaHack.Common.ActorState-  ( actorAssocsLvl, actorAssocs, actorList-  , actorNotProjAssocsLvl, actorNotProjAssocs, actorNotProjList-  , calculateTotal, nearbyFreePoints, whereTo-  , posToActors, posToActor, getItemBody, memActor-  , getActorBody, updateActorBody-  , getActorItem, getFloorItem, getActorBag-  , actorContainer, actorContainerB, getActorInv-  , tryFindHeroK, foesAdjacent+  ( fidActorNotProjAssocs, fidActorNotProjList+  , actorAssocsLvl, actorAssocs, actorList+  , actorRegularAssocsLvl, actorRegularAssocs, actorRegularList+  , bagAssocs, bagAssocsK, calculateTotal+  , sharedAllOwned, sharedAllOwnedFid+  , getCBag, getActorBag, getBodyActorBag, getActorAssocs+  , nearbyFreePoints, whereTo, getCarriedAssocs+  , posToActors, posToActor, getItemBody, memActor, getActorBody+  , tryFindHeroK, getLocalTime+  , itemPrice, calmEnough, hpEnough, regenCalmDelta+  , actorInAmbient, actorSkills, dispEnemy, radiusBlind+  , fullAssocs, itemToFull, goesIntoInv, eqpOverfull, storeFromC   ) where  import Control.Exception.Assert.Sugar import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES+import Data.Int (Int64) import Data.List import Data.Maybe +import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor+import qualified Game.LambdaHack.Common.Effect as Effect 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.Point import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.TileKind +fidActorNotProjAssocs :: FactionId -> State -> [(ActorId, Actor)]+fidActorNotProjAssocs fid s =+  let f (_, b) = not (bproj b) && bfid b == fid+  in filter f $ EM.assocs $ sactorD s++fidActorNotProjList :: FactionId -> State -> [Actor]+fidActorNotProjList fid s = map snd $ fidActorNotProjAssocs fid s+ actorAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict                -> [(ActorId, Actor)] actorAssocsLvl p lvl actorD =-  mapMaybe (\aid -> let actor = actorD EM.! aid-                    in if p (bfid actor)-                       then Just (aid, actor)+  mapMaybe (\aid -> let b = actorD EM.! aid+                    in if p (bfid b)+                       then Just (aid, b)                        else Nothing)   $ concat $ EM.elems $ lprio lvl @@ -48,24 +66,39 @@           -> [Actor] actorList p lid s = map snd $ actorAssocs p lid s -actorNotProjAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict+actorRegularAssocsLvl :: (FactionId -> Bool) -> Level -> ActorDict                       -> [(ActorId, Actor)]-actorNotProjAssocsLvl p lvl actorD =-  mapMaybe (\aid -> let actor = actorD EM.! aid-                    in if not (bproj actor) && p (bfid actor)-                       then Just (aid, actor)+actorRegularAssocsLvl p lvl actorD =+  mapMaybe (\aid -> let b = actorD EM.! aid+                    in if not (bproj b) && bhp b > 0 && p (bfid b)+                       then Just (aid, b)                        else Nothing)   $ concat $ EM.elems $ lprio lvl -actorNotProjAssocs :: (FactionId -> Bool) -> LevelId -> State+actorRegularAssocs :: (FactionId -> Bool) -> LevelId -> State                    -> [(ActorId, Actor)]-actorNotProjAssocs p lid s =-  actorNotProjAssocsLvl p (sdungeon s EM.! lid) (sactorD s)+actorRegularAssocs p lid s =+  actorRegularAssocsLvl p (sdungeon s EM.! lid) (sactorD s) -actorNotProjList :: (FactionId -> Bool) -> LevelId -> State+actorRegularList :: (FactionId -> Bool) -> LevelId -> State                  -> [Actor]-actorNotProjList p lid s = map snd $ actorNotProjAssocs p lid s+actorRegularList p lid s = map snd $ actorRegularAssocs p lid s +getItemBody :: ItemId -> State -> Item+getItemBody iid s =+  fromMaybe (assert `failure` "item body not found"+                    `twith` (iid, s)) $ EM.lookup iid $ sitemD s++bagAssocs :: State -> ItemBag -> [(ItemId, Item)]+bagAssocs s bag =+  let iidItem iid = (iid, getItemBody iid s)+  in map iidItem $ EM.keys bag++bagAssocsK :: State -> ItemBag -> [(ItemId, (Item, Int))]+bagAssocsK s bag =+  let iidItem (iid, k) = (iid, (getItemBody iid s, k))+  in map iidItem $ EM.assocs bag+ -- | Finds an actor at a position on the current level. posToActor :: Point -> LevelId -> State            -> Maybe ((ActorId, Actor), [(ItemId, Item)])@@ -76,18 +109,20 @@ posToActors pos lid s =   let as = actorAssocs (const True) lid s       aps = filter (\(_, b) -> bpos b == pos) as-      f iid = (iid, getItemBody iid s)-      g (aid, b) = ((aid, b), map f $ EM.keys $ bbag b)+      g (aid, b) = ( (aid, b)+                   , bagAssocs s (binv b)+                     ++ bagAssocs s (beqp b)+                     ++ bagAssocs s (borgan b) )       l = map g aps   in assert (length l <= 1 || all (bproj . snd . fst) l              `blame` "many actors at the same position" `twith` l)      l -nearbyFreePoints :: Kind.Ops TileKind-                 -> (Kind.Id TileKind -> Bool) -> Point -> LevelId -> State+nearbyFreePoints :: (Kind.Id TileKind -> Bool) -> Point -> LevelId -> State                  -> [Point]-nearbyFreePoints cotile f start lid s =-  let lvl@Level{lxsize, lysize} = sdungeon s EM.! lid+nearbyFreePoints f start lid s =+  let Kind.COps{cotile} = scops s+      lvl@Level{lxsize, lysize} = sdungeon s EM.! lid       as = actorList (const True) lid s       good p = f (lvl `at` p)                && Tile.isWalkable cotile (lvl `at` p)@@ -95,19 +130,34 @@       ps = nub $ start : concatMap (vicinity lxsize lysize) ps   in filter good ps --- | Calculate loot's worth for heroes on the current level.------ Warning: scores are shown during the game, so when the server calculates--- then, we should be careful not to leak secret information--- (e.g., the nature of the items through the total worth of inventory).+-- | Calculate loot's worth for a faction of a given actor. calculateTotal :: Actor -> State -> (ItemBag, Int) calculateTotal body s =-  let bs = actorList (== bfid body) (blid body) s-      bag = EM.unionsWith (+) $ map bbag $ if null bs then [body] else bs-      items = map (\(iid, k) -> (getItemBody iid s, k))-              $ EM.assocs bag+  let bag = sharedAllOwned body s+      items = map (\(iid, k) -> (getItemBody iid s, k)) $ EM.assocs bag   in (bag, sum $ map itemPrice items) +sharedInv :: Actor -> State -> ItemBag+sharedInv body s =+  let bs = fidActorNotProjList (bfid body) s+  in EM.unionsWith (+) $ map binv $ if null bs then [body] else bs++sharedEqp :: Actor -> State -> ItemBag+sharedEqp body s =+  let bs = fidActorNotProjList (bfid body) s+  in EM.unionsWith (+) $ map beqp $ if null bs then [body] else bs++sharedAllOwned :: Actor -> State -> ItemBag+sharedAllOwned body s =+  let shaBag = gsha $ sfactionD s EM.! bfid body+  in EM.unionsWith (+) [sharedEqp body s, sharedInv body s, shaBag]++sharedAllOwnedFid :: FactionId -> State -> ItemBag+sharedAllOwnedFid fid s =+  let shaBag = gsha $ sfactionD s EM.! fid+      bs = fidActorNotProjList fid s+  in EM.unionsWith (+) $ map binv bs ++ map beqp bs ++ [shaBag]+ -- | Price an item, taking count into consideration. itemPrice :: (Item, Int) -> Int itemPrice (item, jcount) =@@ -116,12 +166,6 @@     '*' -> jcount * 100     _   -> 0 -foesAdjacent :: X -> Y -> Point -> [Actor] -> Bool-foesAdjacent lxsize lysize pos foes =-  let vic = ES.fromList $ vicinity lxsize lysize pos-      lfs = ES.fromList $ map bpos foes-  in not $ ES.null $ ES.intersection vic lfs- -- * These few operations look at, potentially, all levels of the dungeon.  -- | Tries to finds an actor body satisfying a predicate on any level.@@ -170,50 +214,35 @@   fromMaybe (assert `failure` "body not found" `twith` (aid, s))   $ EM.lookup aid $ sactorD s -updateActorBody :: ActorId -> (Actor -> Actor) -> State -> State-updateActorBody aid f s =-  let alt Nothing = assert `failure` "no body to update" `twith` (aid, s)-      alt (Just b) = Just $ f b-  in updateActorD (EM.alter alt aid) s--getActorBag :: ActorId -> State -> ItemBag-getActorBag aid s = bbag $ getActorBody aid s--actorContainer :: ActorId -> ItemInv -> ItemId -> Container-actorContainer aid binv iid =-  case find ((== iid) . snd) $ EM.assocs binv of-    Just (l, _) -> CActor aid l-    Nothing -> assert `failure` "item not in inventory" `twith` (aid, binv, iid)+getCarriedAssocs :: Actor -> State -> [(ItemId, Item)]+getCarriedAssocs b s =+  bagAssocs s $ EM.unionsWith (const) [binv b, beqp b, borgan b] -actorContainerB :: ActorId -> Actor -> ItemId -> Item -> Maybe Container-actorContainerB aid body iid item =-  case find ((== iid) . snd) $ EM.assocs (binv body) of-    Just (l, _) -> Just $ CActor aid l-    Nothing ->-      let l = if jsymbol item == '$' then Just $ InvChar '$' else Nothing-      in case assignLetter iid l body of-        Just l2 -> Just $ CActor aid l2-        Nothing -> Nothing+getCBag :: Container -> State -> ItemBag+getCBag c s = case c of+  CFloor lid p -> sdungeon s EM.! lid `atI` p+  CActor aid cstore -> getActorBag aid cstore s+  CTrunk fid _ _ -> sharedAllOwnedFid fid s -getActorInv :: ActorId -> State -> ItemInv-getActorInv aid s = binv $ getActorBody aid s+getActorBag :: ActorId -> CStore -> State -> ItemBag+getActorBag aid cstore s =+  let b = getActorBody aid s+  in getBodyActorBag b cstore s --- | Gets actor's items from the current level. Warning: this does not work--- for viewing items of actors from remote level.-getActorItem :: ActorId -> State -> [(ItemId, Item)]-getActorItem aid s =-  let f iid = (iid, getItemBody iid s)-  in map f $ EM.keys $ getActorBag aid s+getBodyActorBag :: Actor -> CStore -> State -> ItemBag+getBodyActorBag b cstore s =+  case cstore of+    CGround -> sdungeon s EM.! blid b `atI` bpos b+    COrgan -> borgan b+    CEqp -> beqp b+    CInv -> binv b+    CSha -> gsha $ sfactionD s EM.! bfid b -getFloorItem :: LevelId -> Point -> State -> [(ItemId, Item)]-getFloorItem lid pos s =-  let f iid = (iid, getItemBody iid s)-  in map f $ EM.keys $ sdungeon s EM.! lid `atI` pos+getActorAssocs :: ActorId -> CStore -> State -> [(ItemId, Item)]+getActorAssocs aid cstore s = bagAssocs s $ getActorBag aid cstore s -getItemBody :: ItemId -> State -> Item-getItemBody iid s =-  fromMaybe (assert `failure` "item body not found"-                    `twith` (iid, s)) $ EM.lookup iid $ sitemD s+getActorAssocsK :: ActorId -> CStore -> State -> [(ItemId, (Item, Int))]+getActorAssocsK aid cstore s = bagAssocsK s $ getActorBag aid cstore s  -- | Checks if the actor is present on the current level. -- The order of argument here and in other functions is set to allow@@ -222,3 +251,109 @@ memActor :: ActorId -> LevelId -> State -> Bool memActor aid lid s =   maybe False ((== lid) . blid) $ EM.lookup aid $ sactorD s++calmEnough :: Actor -> [ItemFull] -> Bool+calmEnough b activeItems =+  let calmMax = max 1 $ sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems+  in 2 * xM calmMax <= 3 * bcalm b++hpEnough :: Actor -> [ItemFull] -> Bool+hpEnough b activeItems =+  let hpMax = max 1 $ sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems+  in 2 * xM hpMax <= 3 * bhp b++-- | Get current time from the dungeon data.+getLocalTime :: LevelId -> State -> Time+getLocalTime lid s = ltime $ sdungeon s EM.! lid++regenCalmDelta :: Actor -> [ItemFull] -> State -> Int64+regenCalmDelta b activeItems s =+  let calmMax = sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems+      calmIncr = oneM  -- normal rate of calm regen+      maxDeltaCalm = xM calmMax - bcalm b+      -- Worry actor by enemies felt (even if not seen)+      -- on the level within 3 tiles.+      fact = (EM.! bfid b) . sfactionD $ s+      allFoes = actorRegularList (isAtWar fact) (blid b) $ s+      isHeard body = not (waitedLastTurn body)+                     && chessDist (bpos b) (bpos body) <= 3+      noisyFoes = filter isHeard allFoes+  in if null noisyFoes+     then min calmIncr maxDeltaCalm+     else minusM  -- even if all calmness spent, keep informing the client++actorInAmbient :: Actor -> State -> Bool+actorInAmbient b s =+  let Kind.COps{cotile} = scops s+      lvl = (EM.! blid b) . sdungeon $ s+  in Tile.isLit cotile (lvl `at` bpos b)++actorSkills :: ActorId -> Maybe ActorId -> [ItemFull] -> State -> Ability.Skills+actorSkills aid mleader activeItems s =+  let Kind.COps{cofaction=Kind.Ops{okind}} = scops s+      body = getActorBody aid s+      fact = (EM.! bfid body) . sfactionD $ s+      factionSkills+        | Just aid == mleader = fSkillsLeader $ okind $ gkind fact+        | otherwise = fSkillsOther $ okind $ gkind 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 =+  let hasSupport b =+        let fact = (EM.! bfid b) . sfactionD $ s+            friendlyFid fid = fid == bfid b || isAllied fact fid+            sup = actorRegularList friendlyFid (blid b) s+        in any (adjacent (bpos b) . bpos) sup+      actorSk = actorSkills target (Just target) activeItems s+      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+             || hasSupport sb && hasSupport tb)  -- solo actors are flexible++-- | Determine if the sight radius is high enough to deem the actor capable+-- of projecting items and similar activities. Otherwise, the actor+-- is assumed to use a combination of peripherial vision, hearing, etc.,+-- and not the actual focused, long-distance sight sense.+radiusBlind :: Int -> Bool+radiusBlind radius = radius < 4++fullAssocs :: Kind.COps -> Discovery -> DiscoAE+           -> ActorId -> [CStore] -> State+           -> [(ItemId, ItemFull)]+fullAssocs cops disco discoAE aid cstores s =+  let allAssocs = concatMap (\cstore -> getActorAssocsK aid cstore s) cstores+      iToFull (iid, (item, k)) =+        (iid, itemToFull cops disco discoAE iid item k)+  in map iToFull allAssocs++itemToFull :: Kind.COps -> Discovery -> DiscoAE -> ItemId -> Item -> Int+           -> ItemFull+itemToFull Kind.COps{coitem=Kind.Ops{okind}}+           disco discoAE iid itemBase itemK =+  let itemDisco = case EM.lookup (jkindIx itemBase) disco of+        Nothing -> Nothing+        Just itemKindId -> Just ItemDisco{ itemKindId+                                         , itemKind = okind itemKindId+                                         , itemAE = EM.lookup iid discoAE }+  in ItemFull {..}++goesIntoInv :: Item -> Bool+goesIntoInv item = isNothing $ strengthEqpSlot item++eqpOverfull :: Actor -> Int -> Bool+eqpOverfull b n = let size = sum $ EM.elems $ beqp b+                  in assert (size <= 10 `blame` (b, n, size))+                     $ size + n > 10++storeFromC :: Container -> CStore+storeFromC c = case c of+  CFloor{} -> CGround+  CActor _ cstore -> cstore+  CTrunk{} -> CGround
− Game/LambdaHack/Common/Animation.hs 
@@ -1,312 +0,0 @@-{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}--- | Screen frames and animations.-module Game.LambdaHack.Common.Animation-  ( SingleFrame(..), decodeLine, encodeLine-  , overlayOverlay, xsizeSingleFrame, ysizeSingleFrame-  , Animation, Frames, renderAnim, restrictAnim-  , twirlSplash, blockHit, blockMiss, deathBody, swapPlaces, fadeout-  , AcFrame(..)-  , DebugModeCli(..), defDebugModeCli-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import Data.Binary-import Data.Bits-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Int (Int32)-import Data.List-import Data.Maybe-import Data.Monoid-import qualified Data.Text as T-import qualified Data.Vector.Generic as G-import qualified Data.Vector.Unboxed as U-import GHC.Generics (Generic)--import Game.LambdaHack.Common.Color-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random--type ScreenLine = U.Vector Int32--decodeLine :: ScreenLine -> [AttrChar]-decodeLine v = map (toEnum . fromIntegral) $ G.toList v--encodeLine :: [AttrChar] -> ScreenLine-encodeLine l = G.fromList $ map (fromIntegral . fromEnum) l---- | The data sufficent to draw a single game screen frame.-data SingleFrame = SingleFrame-  { sfLevel  :: ![ScreenLine]  -- ^ screen, from top to bottom, line by line-  , sfTop    :: !Overlay       -- ^ some extra lines to show over the top-  , sfBottom :: ![ScreenLine]  -- ^ some extra lines to show at the bottom-  , sfBlank  :: !Bool          -- ^ display only @sfTop@, on blank screen-  }-  deriving (Eq, Show)---- | Overlays the @sfTop@ and @sfBottom@ fields onto the @sfLevel@ field.--- The resulting frame has empty @sfTop@ and @sfBottom@.--- To be used by simple frontends that don't display overlays--- in separate windows/panes/scrolled views.-overlayOverlay :: SingleFrame -> SingleFrame-overlayOverlay sf@SingleFrame{..} =-  let lxsize = xsizeSingleFrame sf-      lysize = ysizeSingleFrame sf-      emptyLine = encodeLine-                  $ replicate lxsize (Color.AttrChar Color.defAttr ' ')-      canvasLength = if sfBlank then lysize + 3 else lysize + 1-      canvas | sfBlank = replicate canvasLength emptyLine-             | otherwise = emptyLine : sfLevel-      topTrunc = map (truncateMsg lxsize) $ overlay sfTop-      topLayer = if length topTrunc <= canvasLength-                 then topTrunc-                 else take (canvasLength - 1) topTrunc-                      ++ ["--a portion of the text trimmed--"]-      addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      f layerLine canvasLine = encodeLine-        $ addAttr layerLine-          ++ drop (T.length layerLine) (decodeLine canvasLine)-      picture = zipWith f topLayer canvas-      bottomLines = if sfBlank then [] else sfBottom-      newLevel = picture ++ drop (length picture) canvas ++ bottomLines-  in SingleFrame { sfLevel = newLevel-                 , sfTop = emptyOverlay-                 , sfBottom = []-                 , sfBlank }---- | Animation is a list of frame modifications to play one by one,--- where each modification if a map from positions to level map symbols.-newtype Animation = Animation [EM.EnumMap Point AttrChar]-  deriving (Eq, Show, Monoid)---- | Sequences of screen frames, including delays.-type Frames = [Maybe SingleFrame]--xsizeSingleFrame :: SingleFrame -> X-xsizeSingleFrame SingleFrame{sfLevel=[]} = 0-xsizeSingleFrame SingleFrame{sfLevel=line : _} = G.length line--ysizeSingleFrame :: SingleFrame -> X-ysizeSingleFrame SingleFrame{sfLevel} = length sfLevel---- | Render animations on top of a screen frame.-renderAnim :: X -> Y -> SingleFrame -> Animation -> Frames-renderAnim lxsize lysize basicFrame (Animation anim) =-  let modifyFrame SingleFrame{sfLevel = []} _ =-        assert `failure` (lxsize, lysize, basicFrame, anim)-      modifyFrame SingleFrame{sfLevel = levelOld, ..} am =-        let fLine y lineOld =-              let f l (x, acOld) =-                    let pos = Point x y-                        !ac = fromMaybe acOld $ EM.lookup pos am-                    in ac : l-              in foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld))-            sfLevel =  -- fully evaluated inside-              let f l (y, lineOld) = let !line = fLine y lineOld in line : l-              in map encodeLine-                 $ foldl' f [] (zip [lysize-1,lysize-2..0]-                                $ reverse $ map decodeLine levelOld)-        in Just SingleFrame{..}  -- a thunk within Just-  in map (modifyFrame basicFrame) anim--blank :: Maybe AttrChar-blank = Nothing--coloredSymbol :: Color -> Char -> Maybe AttrChar-coloredSymbol color symbol = Just $ AttrChar (Attr color defBG) symbol--mzipPairs :: (Point, Point) -> (Maybe AttrChar, Maybe AttrChar)-          -> [(Point, AttrChar)]-mzipPairs (p1, p2) (mattr1, mattr2) =-  let mzip (pos, mattr) = fmap (\x -> (pos, x)) mattr-  in catMaybes $ if p1 /= p2-                 then [mzip (p1, mattr1), mzip (p2, mattr2)]-                 else -- If actor affects himself, show only the effect,-                      -- not the action.-                      [mzip (p1, mattr1)]--restrictAnim :: ES.EnumSet Point -> Animation -> Animation-restrictAnim vis (Animation as) =-  let f imap =-        let common = EM.intersection imap $ EM.fromSet (const ()) vis-          in if EM.null common then Nothing else Just common-  in Animation $ mapMaybe f as---- | 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)-  [ (coloredSymbol BrWhite '*', blank)-  , (coloredSymbol c1      '/', coloredSymbol BrCyan '^')-  , (coloredSymbol c1      '-', blank)-  , (coloredSymbol c1      '\\',blank)-  , (coloredSymbol c1      '|', blank)-  , (coloredSymbol c2      '%', blank)-  , (coloredSymbol c2      '%', blank)-  , (blank                    , blank)-  ]---- | Attack that hits through a block.-blockHit :: (Point, Point) -> Color -> Color -> Animation-blockHit poss c1 c2 = Animation $ map (EM.fromList . mzipPairs poss)-  [ (coloredSymbol BrWhite '*', blank)-  , (coloredSymbol BrBlue  '{', coloredSymbol BrCyan '^')-  , (coloredSymbol BrBlue  '{', blank)-  , (coloredSymbol BrBlue  '}', blank)-  , (coloredSymbol c1      '/', blank)-  , (coloredSymbol c2      '%', blank)-  , (coloredSymbol c2      '%', blank)-  , (blank                    , blank)-  ]---- | Attack that is blocked.-blockMiss :: (Point, Point) -> Animation-blockMiss poss = Animation $ map (EM.fromList . mzipPairs poss)-  [ (coloredSymbol BrWhite '*', blank)-  , (coloredSymbol BrBlue  '{', coloredSymbol BrCyan '\'')-  , (coloredSymbol BrBlue  '}', blank)-  , (blank                    , 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   ','-  ]---- | Swap-places animation, both hostile and friendly.-swapPlaces :: (Point, Point) -> Animation-swapPlaces poss = Animation $ map (EM.fromList . mzipPairs poss)-  [ (coloredSymbol BrMagenta '.', coloredSymbol Magenta   'o')-  , (coloredSymbol BrMagenta 'd', coloredSymbol Magenta   'p')-  , (coloredSymbol Magenta   'p', coloredSymbol BrMagenta 'd')-  , (coloredSymbol Magenta   'o', blank)-  ]--fadeout :: Bool -> Bool -> X -> Y -> Rnd Animation-fadeout out topRight lxsize lysize = do-  let xbound = lxsize - 1-      ybound = lysize - 1-      edge = EM.fromDistinctAscList $ zip [1..] ".%&%;:,."-      fadeChar r n x y =-        let d = x - 2 * y-            ndy = n - d - 2 * ybound-            ndx = n + d - xbound - 1  -- @-1@ for asymmetry-            mnx = if ndy > 0 && ndx > 0-                  then min ndy ndx-                  else max ndy ndx-            v3 = (r `xor` (x * y)) `mod` 3-            k | mnx < 3 || mnx > 10 = mnx-              | (min x (xbound - x - y) + n + v3) `mod` 15 < 11-                && mnx > 6 = mnx - v3-              | (x + 3 * y + v3) `mod` 30 < 19 = mnx + 1-              | otherwise = mnx-        in EM.findWithDefault ' ' k edge-      rollFrame n = do-        r <- random-        let l = [ ( Point (if topRight then x else xbound - x) y-                  , AttrChar defAttr $ fadeChar r n x y )-                | x <- [0..xbound]-                , y <- [max 0 (ybound - (n - x) `div` 2)..ybound]-                    ++ [0..min ybound ((n - xbound + x) `div` 2)]-                ]-        return $! EM.fromList l-      startN = if out then 3 else 1-      fs = [startN..3 * lxsize `divUp` 4 + 2]-  as <- mapM rollFrame $ if out then fs else reverse fs-  return $! Animation as--data AcFrame =-    AcConfirm !SingleFrame-  | AcRunning !SingleFrame-  | AcNormal !SingleFrame-  | AcDelay-  deriving (Show, Eq)--data DebugModeCli = DebugModeCli-  { sfont          :: !(Maybe String)-      -- ^ Font to use for the main game window.-  , smaxFps        :: !(Maybe Int)-      -- ^ Maximal frames per second.-      -- This is better low and fixed, to avoid jerkiness and delays-      -- that tell the player there are many intelligent enemies on the level.-      -- That's better than scaling AI sofistication down based-      -- on the FPS setting and machine speed.-  , snoDelay       :: !Bool-      -- ^ Don't maintain any requested delays between frames,-      -- e.g., for screensaver.-  , snoMore        :: !Bool-      -- ^ Auto-answer all prompts, e.g., for screensaver.-  , snoAnim        :: !(Maybe Bool)-      -- ^ Don't show any animations.-  , snewGameCli    :: !Bool-      -- ^ Start a new game, overwriting the save file.-  , sdifficultyCli :: !Int-      -- ^ The difficulty level for all UI clients.-  , ssavePrefixCli :: !(Maybe String)-      -- ^ Prefix of the save game file.-  , sfrontendStd   :: !Bool-      -- ^ Whether to use the stdout/stdin frontend.-  , sfrontendNo    :: !Bool-      -- ^ Whether to use no frontend at all (for benchmarking, etc.).-  , sdbgMsgCli     :: !Bool-      -- ^ Show clients' internal debug messages.-  }-  deriving (Show, Eq, Generic)--defDebugModeCli :: DebugModeCli-defDebugModeCli = DebugModeCli-  { sfont = Nothing-  , smaxFps = Nothing-  , snoDelay = False-  , snoMore = False-  , snoAnim = Nothing-  , snewGameCli = False-  , sdifficultyCli = 0-  , ssavePrefixCli = Nothing-  , sfrontendStd = False-  , sfrontendNo = False-  , sdbgMsgCli = False-  }--instance Binary AcFrame where-  put (AcConfirm fr) = putWord8 0 >> put fr-  put (AcRunning fr) = putWord8 1 >> put fr-  put (AcNormal fr)  = putWord8 2 >> put fr-  put AcDelay        = putWord8 3-  get = do-    tag <- getWord8-    case tag of-      0 -> liftM AcConfirm get-      1 -> liftM AcRunning get-      2 -> liftM AcNormal get-      3 -> return AcDelay-      _ -> fail "no parse (AcFrame)"--instance Binary SingleFrame where-  put SingleFrame{..} = do-    put sfLevel-    put sfTop-    put sfBottom-    put sfBlank-  get = do-    sfLevel <- get-    sfTop <- get-    sfBottom <- get-    sfBlank <- get-    return $! SingleFrame{..}--instance Binary DebugModeCli
− Game/LambdaHack/Common/AtomicCmd.hs 
@@ -1,186 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | A set of atomic commands shared by client and server.--- These are the largest building blocks that have no components--- that can be observed in isolation.------ We try to make atomic commands respect the laws of energy and mass--- conservation, unless they really can't, e.g., monster spawning.--- For example item removal from inventory is not an atomic command,--- but item dropped from the inventory to the ground is. This makes--- it easier to undo the commands. In principle, the commands are the only--- way to affect the basic game state (@State@).------ See--- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Common.AtomicCmd-  ( Atomic(..), CmdAtomic(..), SfxAtomic(..), HitAtomic(..)-  , undoCmdAtomic, undoSfxAtomic, undoAtomic-  ) where--import Data.Binary-import Data.Text (Text)-import GHC.Generics (Generic)--import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.Animation-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind as ItemKind-import Game.LambdaHack.Content.TileKind as TileKind--data Atomic =-    CmdAtomic !CmdAtomic-  | SfxAtomic !SfxAtomic-  deriving (Show, Eq, Generic)--instance Binary Atomic---- | Abstract syntax of atomic commands.-data CmdAtomic =-  -- Create/destroy actors and items.-    CreateActorA !ActorId !Actor ![(ItemId, Item)]-  | DestroyActorA !ActorId !Actor ![(ItemId, Item)]-  | CreateItemA !ItemId !Item !Int !Container-  | DestroyItemA !ItemId !Item !Int !Container-  | SpotActorA !ActorId !Actor ![(ItemId, Item)]-  | LoseActorA !ActorId !Actor ![(ItemId, Item)]-  | SpotItemA !ItemId !Item !Int !Container-  | LoseItemA !ItemId !Item !Int !Container-  -- Move actors and items.-  | MoveActorA !ActorId !Point !Point-  | WaitActorA !ActorId !Bool !Bool-  | DisplaceActorA !ActorId !ActorId-  | MoveItemA !ItemId !Int !Container !Container-  -- Change actor attributes.-  | AgeActorA !ActorId !Time-  | HealActorA !ActorId !Int-  | HasteActorA !ActorId !Speed-  | TrajectoryActorA !ActorId !(Maybe [Vector]) !(Maybe [Vector])-  | ColorActorA !ActorId !Color.Color !Color.Color-  -- Change faction attributes.-  | QuitFactionA !FactionId !(Maybe Actor) !(Maybe Status) !(Maybe Status)-  | LeadFactionA !FactionId !(Maybe ActorId) !(Maybe ActorId)-  | DiplFactionA !FactionId !FactionId !Diplomacy !Diplomacy-  -- Alter map.-  | AlterTileA !LevelId !Point !(Kind.Id TileKind) !(Kind.Id TileKind)-  | SearchTileA !ActorId !Point !(Kind.Id TileKind) !(Kind.Id TileKind)-  | SpotTileA !LevelId ![(Point, Kind.Id TileKind)]-  | LoseTileA !LevelId ![(Point, Kind.Id TileKind)]-  | AlterSmellA !LevelId !Point !(Maybe Time) !(Maybe Time)-  | SpotSmellA !LevelId ![(Point, Time)]-  | LoseSmellA !LevelId ![(Point, Time)]-  -- Assorted.-  | AgeLevelA !LevelId !Time-  | AgeGameA !Time-  | DiscoverA !LevelId !Point !ItemId !(Kind.Id ItemKind)-  | CoverA !LevelId !Point !ItemId !(Kind.Id ItemKind)-  | PerceptionA !LevelId !Perception !Perception-  | RestartA !FactionId !Discovery !FactionPers !State !DebugModeCli !Text-  | RestartServerA !State-  | ResumeA !FactionId !FactionPers-  | ResumeServerA !State-  | KillExitA !FactionId-  | SaveBkpA-  | MsgAllA !Msg-  deriving (Show, Eq, Generic)--instance Binary CmdAtomic--data SfxAtomic =-    StrikeD !ActorId !ActorId !Item !HitAtomic-  | RecoilD !ActorId !ActorId !Item !HitAtomic-  | ProjectD !ActorId !ItemId-  | CatchD !ActorId !ItemId-  | ActivateD !ActorId !ItemId-  | CheckD !ActorId !ItemId-  | TriggerD !ActorId !Point !F.Feature-  | ShunD !ActorId !Point !F.Feature-  | EffectD !ActorId !(Effect.Effect Int)-  | MsgFidD !FactionId !Msg-  | MsgAllD !Msg-  | DisplayPushD !FactionId-  | DisplayDelayD !FactionId-  | RecordHistoryD !FactionId-  deriving (Show, Eq, Generic)--instance Binary SfxAtomic--data HitAtomic = HitD | HitBlockD | MissBlockD-  deriving (Show, Eq, Generic)--instance Binary HitAtomic--undoCmdAtomic :: CmdAtomic -> Maybe CmdAtomic-undoCmdAtomic cmd = case cmd of-  CreateActorA aid body ais -> Just $ DestroyActorA aid body ais-  DestroyActorA aid body ais -> Just $ CreateActorA aid body ais-  CreateItemA iid item k c -> Just $ DestroyItemA iid item k c-  DestroyItemA iid item k c -> Just $ CreateItemA iid item k c-  SpotActorA aid body ais -> Just $ LoseActorA aid body ais-  LoseActorA aid body ais -> Just $ SpotActorA aid body ais-  SpotItemA iid item k c -> Just $ LoseItemA iid item k c-  LoseItemA iid item k c -> Just $ SpotItemA iid item k c-  MoveActorA aid fromP toP -> Just $ MoveActorA aid toP fromP-  WaitActorA aid fromWait toWait -> Just $ WaitActorA aid toWait fromWait-  DisplaceActorA source target -> Just $ DisplaceActorA target source-  MoveItemA iid k c1 c2 ->Just $  MoveItemA iid k c2 c1-  AgeActorA aid t -> Just $ AgeActorA aid (timeNegate t)-  HealActorA aid n -> Just $ HealActorA aid (-n)-  HasteActorA aid delta -> Just $ HasteActorA aid (speedNegate delta)-  TrajectoryActorA aid fromT toT -> Just $ TrajectoryActorA aid toT fromT-  ColorActorA aid fromCol toCol -> Just $ ColorActorA aid toCol fromCol-  QuitFactionA fid mb fromSt toSt -> Just $ QuitFactionA fid mb toSt fromSt-  LeadFactionA fid source target -> Just $ LeadFactionA fid target source-  DiplFactionA fid1 fid2 fromDipl toDipl ->-    Just $ DiplFactionA fid1 fid2 toDipl fromDipl-  AlterTileA lid p fromTile toTile -> Just $ AlterTileA lid p toTile fromTile-  SearchTileA aid p fromTile toTile -> Just $ SearchTileA aid p toTile fromTile-  SpotTileA lid ts -> Just $ LoseTileA lid ts-  LoseTileA lid ts -> Just $ SpotTileA lid ts-  AlterSmellA lid p fromSm toSm -> Just $ AlterSmellA lid p toSm fromSm-  SpotSmellA lid sms -> Just $ LoseSmellA lid sms-  LoseSmellA lid sms -> Just $ SpotSmellA lid sms-  AgeLevelA lid t -> Just $ AgeLevelA lid (timeNegate t)-  AgeGameA t -> Just $ AgeGameA (timeNegate t)-  DiscoverA lid p iid ik -> Just $ CoverA lid p iid ik-  CoverA lid p iid ik -> Just $ DiscoverA lid p iid ik-  PerceptionA lid outPer inPer -> Just $ PerceptionA lid inPer outPer-  RestartA{} -> Just cmd  -- here history ends; change direction-  RestartServerA{} -> Just cmd  -- here history ends; change direction-  ResumeA{} -> Nothing-  ResumeServerA{} -> Nothing-  KillExitA{} -> Nothing-  SaveBkpA -> Nothing-  MsgAllA{} -> Nothing  -- only generated by @cmdAtomicFilterCli@--undoSfxAtomic :: SfxAtomic -> SfxAtomic-undoSfxAtomic cmd = case cmd of-  StrikeD source target item b -> RecoilD source target item b-  RecoilD source target item b -> StrikeD source target item b-  ProjectD aid iid -> CatchD aid iid-  CatchD aid iid -> ProjectD aid iid-  ActivateD aid iid -> CheckD aid iid-  CheckD aid iid -> ActivateD aid iid-  TriggerD aid p feat -> ShunD aid p feat-  ShunD aid p feat -> TriggerD aid p feat-  EffectD{} -> cmd  -- not ideal?-  MsgFidD{} -> cmd-  MsgAllD{} -> cmd-  DisplayPushD{} -> cmd-  DisplayDelayD{} -> cmd-  RecordHistoryD{} -> cmd--undoAtomic :: Atomic -> Maybe Atomic-undoAtomic (CmdAtomic cmd) = fmap CmdAtomic $ undoCmdAtomic cmd-undoAtomic (SfxAtomic sfx) = Just $ SfxAtomic $ undoSfxAtomic sfx
− Game/LambdaHack/Common/AtomicPos.hs 
@@ -1,247 +0,0 @@--- | Semantics of atomic commands shared by client and server.--- See--- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Common.AtomicPos-  ( PosAtomic(..), posCmdAtomic, posSfxAtomic-  , resetsFovAtomic, breakCmdAtomic, loudCmdAtomic-  , seenAtomicCli, seenAtomicSer-  ) where--import Control.Exception.Assert.Sugar-import qualified Data.EnumSet as ES--import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.AtomicCmd-import Game.LambdaHack.Common.AtomicSem (posOfAid, posOfContainer)-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point---- 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.-data PosAtomic =-    PosSight !LevelId ![Point]  -- ^ whomever sees all the positions, notices-  | PosFidAndSight !FactionId !LevelId ![Point]-                                -- ^ observers and the faction notice-  | PosSmell !LevelId ![Point]  -- ^ whomever smells all the positions, notices-  | PosFid !FactionId           -- ^ only the faction notices-  | PosFidAndSer !FactionId     -- ^ faction and server notices-  | PosSer                      -- ^ only the server notices-  | PosAll                      -- ^ everybody notices-  | PosNone                     -- ^ never broadcasted, but sent manually-  deriving (Show, Eq)---- | Produces the positions where the action takes place. If a faction--- is returned, the action is visible only for that faction, if Nothing--- is returned, it's never visible. Empty list of positions implies--- the action is visible always.------ 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., @DisplaceActorA@--- 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 @MoveActorA@--- of the illuminated actor, hence such @DisplaceActorA@ should not be--- observable, but @MoveActorA@ should be (or the former should be perceived--- as the latter). However, to simplify, we assing as strict visibility--- requirements to @MoveActorA@ as to @DisplaceActorA@ and fall back--- to @SpotActorA@ (which provides minimal information that does not--- contradict state) if the visibility is lower.-posCmdAtomic :: MonadActionRO m => CmdAtomic -> m PosAtomic-posCmdAtomic cmd = case cmd of-  CreateActorA _ body _ -> posProjBody body-  DestroyActorA _ body _ -> posProjBody body-  CreateItemA _ _ _ c -> singleContainer c-  DestroyItemA _ _ _ c -> singleContainer c-  SpotActorA _ body _ -> posProjBody body-  LoseActorA _ body _ -> posProjBody body-  SpotItemA _ _ _ c -> singleContainer c-  LoseItemA _ _ _ c -> singleContainer c-  MoveActorA aid fromP toP -> do-    (lid, _) <- posOfAid aid-    return $! PosSight lid [fromP, toP]-  WaitActorA aid _ _ -> singleAid aid-  DisplaceActorA source target -> do-    (slid, sp) <- posOfAid source-    (tlid, tp) <- posOfAid target-    return $! assert (slid == tlid) $ PosSight slid [sp, tp]-  MoveItemA _ _ c1 c2 -> do  -- works even if moved between positions-    (lid1, p1) <- posOfContainer c1-    (lid2, p2) <- posOfContainer c2-    return $! assert (lid1 == lid2) $ PosSight lid1 [p1, p2]-  AgeActorA aid _ -> singleAid aid-  HealActorA aid _ -> singleAid aid-  HasteActorA aid _ -> singleAid aid-  TrajectoryActorA aid _ _ -> singleAid aid-  ColorActorA aid _ _ -> singleAid aid-  QuitFactionA{} -> return PosAll-  LeadFactionA fid _ _ -> return $! PosFidAndSer fid-  DiplFactionA{} -> return PosAll-  AlterTileA lid p _ _ -> return $! PosSight lid [p]-  SearchTileA aid p _ _ -> do-    (lid, pos) <- posOfAid aid-    return $! PosSight lid [pos, p]-  SpotTileA lid ts -> do-    let ps = map fst ts-    return $! PosSight lid ps-  LoseTileA lid ts -> do-    let ps = map fst ts-    return $! PosSight lid ps-  AlterSmellA lid p _ _ -> return $! PosSmell lid [p]-  SpotSmellA lid sms -> do-    let ps = map fst sms-    return $! PosSmell lid ps-  LoseSmellA lid sms -> do-    let ps = map fst sms-    return $! PosSmell lid ps-  AgeLevelA lid _ ->  return $! PosSight lid []-  AgeGameA _ ->  return PosAll-  DiscoverA lid p _ _ -> return $! PosSight lid [p]-  CoverA lid p _ _ -> return $! PosSight lid [p]-  PerceptionA{} -> return PosNone-  RestartA fid _ _ _ _ _ -> return $! PosFid fid-  RestartServerA _ -> return PosSer-  ResumeA fid _ -> return $! PosFid fid-  ResumeServerA _ -> return PosSer-  KillExitA fid -> return $! PosFid fid-  SaveBkpA -> return PosAll-  MsgAllA{} -> return PosAll--posSfxAtomic :: MonadActionRO m => SfxAtomic -> m PosAtomic-posSfxAtomic cmd = case cmd of-  StrikeD source target _ _ -> do-    (slid, sp) <- posOfAid source-    (tlid, tp) <- posOfAid target-    return $! assert (slid == tlid) $ PosSight slid [sp, tp]-  RecoilD source target _ _ -> do-    (slid, sp) <- posOfAid source-    (tlid, tp) <- posOfAid target-    return $! assert (slid == tlid) $ PosSight slid [sp, tp]-  ProjectD aid _ -> singleAid aid-  CatchD aid _ -> singleAid aid-  ActivateD aid _ -> singleAid aid-  CheckD aid _ -> singleAid aid-  TriggerD aid p _ -> do-    (lid, pa) <- posOfAid aid-    return $! PosSight lid [pa, p]-  ShunD aid p _ -> do-    (lid, pa) <- posOfAid aid-    return $! PosSight lid [pa, p]-  EffectD aid _ -> singleAid aid-  MsgFidD fid _ -> return $! PosFid fid-  MsgAllD _ -> return PosAll-  DisplayPushD fid -> return $! PosFid fid-  DisplayDelayD fid -> return $! PosFid fid-  RecordHistoryD fid -> return $! PosFid fid--posProjBody :: Monad m => Actor -> m PosAtomic-posProjBody body = return $!-  if bproj body-  then PosSight (blid body) [bpos body]-  else PosFidAndSight (bfid body) (blid body) [bpos body]--singleAid :: MonadActionRO m => ActorId -> m PosAtomic-singleAid aid = do-  b <- getsState $ getActorBody aid-  return $! PosSight (blid b) [bpos b]--singleContainer :: MonadActionRO m => Container -> m PosAtomic-singleContainer c = do-  (lid, p) <- posOfContainer c-  return $! PosSight lid [p]---- Determines is a command resets FOV. @Nothing@ means it always does.--- A list of faction means it does for each of the factions.--- This is only an optimization to save perception and spot/lose computation.------ Invariant: if @resetsFovAtomic@ determines a faction does not need--- to reset Fov, perception (@ptotal@ to be precise, @psmell@ is irrelevant)--- of that faction does not change upon recomputation. Otherwise,--- save/restore would change game state.-resetsFovAtomic :: MonadActionRO m => CmdAtomic -> m (Maybe [FactionId])-resetsFovAtomic cmd = case cmd of-  CreateActorA _ body _ -> return $ Just [bfid body]-  DestroyActorA _ body _ -> return $ Just [bfid body]-  SpotActorA _ body _ -> return $ Just [bfid body]-  LoseActorA _ body _ -> return $ Just [bfid body]-  CreateItemA{} -> return $ Just []  -- unless shines-  DestroyItemA{} -> return $ Just []  -- ditto-  MoveActorA aid _ _ -> fmap Just $ fidOfAid aid  -- assumption: has no light--- TODO: MoveActorCarryingLIghtA _ _ _ -> return Nothing-  DisplaceActorA source target -> do-    sfid <- fidOfAid source-    tfid <- fidOfAid target-    return $ Just $ if source == target-                    then []-                    else sfid ++ tfid-  MoveItemA{} -> return $ Just []  -- unless shiny-  AlterTileA{} -> return Nothing  -- even if pos not visible initially-  _ -> return $ Just []--fidOfAid :: MonadActionRO m => ActorId -> m [FactionId]-fidOfAid aid = getsState $ (: []) . bfid . getActorBody aid---- | Decompose an atomic action. The original action is visible--- if it's positions are visible both before and after the action--- (in between the FOV might have changed). The decomposed actions--- are only tested vs the FOV after the action and they give reduced--- information that still modifies client's state to match the server state--- wrt the current FOV and the subset of @posCmdAtomic@ that is visible.--- The original actions give more information not only due to spanning--- potentially more positions than those visible. E.g., @MoveActorA@--- informs about the continued existence of the actor between--- moves, v.s., popping out of existence and then back in.-breakCmdAtomic :: MonadActionRO m => CmdAtomic -> m [CmdAtomic]-breakCmdAtomic cmd = case cmd of-  MoveActorA aid _ toP -> do-    b <- getsState $ getActorBody aid-    ais <- getsState $ getActorItem aid-    return [ LoseActorA aid b ais-           , SpotActorA aid b {bpos = toP, boldpos = bpos b} ais ]-  DisplaceActorA source target -> do-    sb <- getsState $ getActorBody source-    sais <- getsState $ getActorItem source-    tb <- getsState $ getActorBody target-    tais <- getsState $ getActorItem target-    return [ LoseActorA source sb sais-           , SpotActorA source sb {bpos = bpos tb, boldpos = bpos sb} sais-           , LoseActorA target tb tais-           , SpotActorA target tb {bpos = bpos sb, boldpos = bpos tb} tais-           ]-  MoveItemA iid k c1 c2 -> do-    item <- getsState $ getItemBody iid-    return [LoseItemA iid item k c1, SpotItemA iid item k c2]-  _ -> return [cmd]--loudCmdAtomic :: FactionId -> CmdAtomic -> Bool-loudCmdAtomic fid cmd = case cmd of-  DestroyActorA _ body _ ->-    -- Death of a party member does not need to be heard, because it's seen.-    not $ fid == bfid body || bproj body-  _ -> False--seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool-seenAtomicCli knowEvents fid per posAtomic =-  case posAtomic of-    PosSight _ ps -> all (`ES.member` totalVisible per) ps || knowEvents-    PosFidAndSight fid2 _ ps ->-      fid == fid2 || all (`ES.member` totalVisible per) ps || knowEvents-    PosSmell _ ps -> all (`ES.member` smellVisible per) ps || knowEvents-    PosFid fid2 -> fid == fid2-    PosFidAndSer fid2 -> fid == fid2-    PosSer -> False-    PosAll -> True-    PosNone -> assert `failure` "no position possible" `twith` fid--seenAtomicSer :: PosAtomic -> Bool-seenAtomicSer posAtomic =-  case posAtomic of-    PosFid _ -> False-    PosNone -> assert `failure` "wrong position for server" `twith` posAtomic-    _ -> True
− Game/LambdaHack/Common/AtomicSem.hs 
@@ -1,433 +0,0 @@--- | Semantics of atomic commands shared by client and server.--- See--- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Common.AtomicSem-  ( cmdAtomicSem-  , posOfAid, posOfContainer-  ) where--import Control.Arrow (second)-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.List--import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.AtomicCmd-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.TileKind as TileKind--cmdAtomicSem :: MonadAction m => CmdAtomic -> m ()-cmdAtomicSem cmd = case cmd of-  CreateActorA aid body ais -> createActorA aid body ais-  DestroyActorA aid body ais -> destroyActorA aid body ais-  CreateItemA iid item k c -> createItemA iid item k c-  DestroyItemA iid item k c -> destroyItemA iid item k c-  SpotActorA aid body ais -> createActorA aid body ais-  LoseActorA aid body ais -> destroyActorA aid body ais-  SpotItemA iid item k c -> createItemA iid item k c-  LoseItemA iid item k c -> destroyItemA iid item k c-  MoveActorA aid fromP toP -> moveActorA aid fromP toP-  WaitActorA aid fromWait toWait -> waitActorA aid fromWait toWait-  DisplaceActorA source target -> displaceActorA source target-  MoveItemA iid k c1 c2 -> moveItemA iid k c1 c2-  AgeActorA aid t -> ageActorA aid t-  HealActorA aid n -> healActorA aid n-  HasteActorA aid delta -> hasteActorA aid delta-  TrajectoryActorA aid fromT toT -> trajectoryActorA aid fromT toT-  ColorActorA aid fromCol toCol -> colorActorA aid fromCol toCol-  QuitFactionA fid mbody fromSt toSt -> quitFactionA fid mbody fromSt toSt-  LeadFactionA fid source target -> leadFactionA fid source target-  DiplFactionA fid1 fid2 fromDipl toDipl ->-    diplFactionA fid1 fid2 fromDipl toDipl-  AlterTileA lid p fromTile toTile -> alterTileA lid p fromTile toTile-  SearchTileA _ _ fromTile toTile ->-    assert (fromTile /= toTile) $ return ()  -- only for clients-  SpotTileA lid ts -> spotTileA lid ts-  LoseTileA lid ts -> loseTileA lid ts-  AlterSmellA lid p fromSm toSm -> alterSmellA lid p fromSm toSm-  SpotSmellA lid sms -> spotSmellA lid sms-  LoseSmellA lid sms -> loseSmellA lid sms-  AgeLevelA lid t -> ageLevelA lid t-  AgeGameA t -> ageGameA t-  DiscoverA{} -> return ()  -- Server keeps all atomic comands so the semantics-  CoverA{} -> return ()     -- of inverses has to be reasonably inverse.-  PerceptionA _ outPer inPer ->-    assert (not (nullPer outPer && nullPer inPer)) skip-  RestartA fid sdisco sfper s _ _ -> restartA fid sdisco sfper s-  RestartServerA s -> restartServerA s-  ResumeA{} -> return ()-  ResumeServerA s -> resumeServerA s-  KillExitA{} -> return ()-  SaveBkpA -> return ()-  MsgAllA{} -> return ()---- | Creates an actor. Note: after this command, usually a new leader--- for the party should be elected (in case this actor is the only one alive).-createActorA :: MonadAction m => ActorId -> Actor -> [(ItemId, Item)] -> m ()-createActorA aid body ais = do-  -- Add actor to @sactorD@.-  let f Nothing = Just body-      f (Just b) = assert `failure` "actor already added"-                          `twith` (aid, body, b)-  modifyState $ updateActorD $ EM.alter f aid-  -- Add actor to @sprio@.-  let g Nothing = Just [aid]-      g (Just l) = assert (aid `notElem` l `blame` "actor already added"-                                           `twith` (aid, body, l))-                   $ Just $ aid : l-  updateLevel (blid body) $ updatePrio $ EM.alter g (btime body)-  -- Actor's items may or may not be already present in @sitemD@,-  -- regardless if they are already present otherwise in the dungeon.-  -- We re-add them all to save time determining which really need it.-  forM_ ais $ \(iid, item) -> do-    let h item1 item2 =-          assert (item1 == item2 `blame` "inconsistent created actor items"-                                 `twith` (aid, body, iid, item1, item2)) item1-    modifyState $ updateItemD $ EM.insertWith h iid item---- | Update a given level data within state.-updateLevel :: MonadAction m => LevelId -> (Level -> Level) -> m ()-updateLevel lid f = modifyState $ updateDungeon $ EM.adjust f lid---- | Kills an actor.-destroyActorA :: MonadAction m => ActorId -> Actor -> [(ItemId, Item)] -> m ()-destroyActorA aid body ais = do-  -- If a leader dies, a new leader should be elected on the server-  -- before this command is executed.-  -- TODO: check this only on the server (e.g., not in LoseActor):-  -- fact <- getsState $ (EM.! bfid body) . sfactionD-  -- assert (Just aid /= gleader fact `blame` (aid, body, fact)) skip-  -- Assert that actor's items belong to @sitemD@. Do not remove those-  -- that do not appear anywhere else, for simplicity and speed.-  itemD <- getsState sitemD-  let match (iid, item) = itemD EM.! iid == item-  assert (allB match ais `blame` "destroyed actor items not found"-                         `twith` (aid, body, ais, itemD)) skip-  -- Remove actor from @sactorD@.-  let f Nothing = assert `failure` "actor already removed" `twith` (aid, body)-      f (Just b) = assert (b == body `blame` "inconsisted destroyed actor body"-                                     `twith` (aid, body, b)) Nothing-  modifyState $ updateActorD $ EM.alter f aid-  -- Remove actor from @sprio@.-  let g Nothing = assert `failure` "actor already removed" `twith` (aid, body)-      g (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-  updateLevel (blid body) $ updatePrio $ EM.alter g (btime body)---- | Create a few copies of an item that is already registered for the dungeon--- (in @sitemRev@ field of @StateServer@).-createItemA :: MonadAction m => ItemId -> Item -> Int -> Container -> m ()-createItemA iid item k c = assert (k > 0) $ do-  -- The item may or may not be already present in @sitemD@,-  -- regardless if it's actually present in the dungeon.-  let f item1 item2 = assert (item1 == item2-                              `blame` "inconsistent created item"-                              `twith` (iid, item, k, c)) item1-  modifyState $ updateItemD $ EM.insertWith f iid item-  case c of-    CFloor lid pos -> insertItemFloor lid iid k pos-    CActor aid l -> insertItemActor iid k l aid--insertItemFloor :: MonadAction m-                => LevelId -> ItemId -> Int -> Point -> m ()-insertItemFloor lid iid k pos =-  let bag = EM.singleton iid k-      mergeBag = EM.insertWith (EM.unionWith (+)) pos bag-  in updateLevel lid $ updateFloor mergeBag--insertItemActor :: MonadAction m-                => ItemId -> Int -> InvChar -> ActorId -> m ()-insertItemActor iid k l aid = do-  let bag = EM.singleton iid k-      upd = EM.unionWith (+) bag-  modifyState $ updateActorBody aid $ \b ->-    b { bbag = upd (bbag b)-      , binv = EM.insert l iid (binv b)-      , bletter = max l (bletter b) }---- | Destroy some copies (possibly not all) of an item.-destroyItemA :: MonadAction m => ItemId -> Item -> Int -> Container -> m ()-destroyItemA iid item 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 (iid `EM.lookup` itemD == Just item `blame` "item already removed"-                                             `twith` (iid, item, itemD)) skip-  case c of-    CFloor lid pos -> deleteItemFloor lid iid k pos-    CActor aid l -> deleteItemActor iid k l aid--deleteItemFloor :: MonadAction m-                => LevelId -> ItemId -> Int -> Point -> m ()-deleteItemFloor lid iid k pos =-  let rmFromFloor (Just bag) =-        let nbag = rmFromBag k iid bag-        in if EM.null nbag then Nothing else Just nbag-      rmFromFloor Nothing = assert `failure` "item already removed"-                                   `twith` (lid, iid, k, pos)-  in updateLevel lid $ updateFloor $ EM.alter rmFromFloor pos--deleteItemActor :: MonadAction m-                => ItemId -> Int -> InvChar -> ActorId -> m ()-deleteItemActor iid k l aid = do-  modifyState $ updateActorBody aid $ \b ->-    b {bbag = rmFromBag k iid (bbag b)}-  -- Do not remove from actor's @binv@, but assert it was there.-  b <- getsState $ getActorBody aid-  assert (l `EM.lookup` binv b == Just iid `blame` "item already removed"-                                           `twith` (iid, l, aid)) skip-  -- Actor's @bletter@ for UI not reset, but checked.-  assert (bletter b >= l`blame` "inconsistent actor inventory letter"-                        `twith` (iid, k, l, aid, bletter b)) skip--moveActorA :: MonadAction m => ActorId -> Point -> Point -> m ()-moveActorA aid fromP toP = assert (fromP /= toP) $ do-  b <- getsState $ getActorBody aid-  assert (fromP == bpos b `blame` "unexpected moved actor position"-                          `twith` (aid, fromP, toP, bpos b, b)) skip-  modifyState $ updateActorBody aid-              $ \body -> body {bpos = toP, boldpos = fromP}--waitActorA :: MonadAction m => ActorId -> Bool -> Bool -> m ()-waitActorA aid fromWait toWait = assert (fromWait /= toWait) $ do-  b <- getsState $ getActorBody aid-  assert (fromWait == bwait b `blame` "unexpected waited actor time"-                              `twith` (aid, fromWait, toWait, bwait b, b)) skip-  modifyState $ updateActorBody aid $ \body -> body {bwait = toWait}--displaceActorA :: MonadAction m => ActorId -> ActorId -> m ()-displaceActorA source target = assert (source /= target) $ do-  spos <- getsState $ bpos . getActorBody source-  tpos <- getsState $ bpos . getActorBody target-  modifyState $ updateActorBody source $ \ b -> b {bpos = tpos, boldpos = spos}-  modifyState $ updateActorBody target $ \ b -> b {bpos = spos, boldpos = tpos}--moveItemA :: MonadAction m => ItemId -> Int -> Container -> Container -> m ()-moveItemA iid k c1 c2 = assert (k > 0 && c1 /= c2) $ do-  (lid1, _) <- posOfContainer c1-  (lid2, _) <- posOfContainer c2-  assert (lid1 == lid2 `blame` "moved item containers not on the same level"-                       `twith` (iid, k, c1, c2, lid1, lid2)) skip-  case c1 of-    CFloor lid pos -> deleteItemFloor lid iid k pos-    CActor aid l -> deleteItemActor iid k l aid-  case c2 of-    CFloor lid pos -> insertItemFloor lid iid k pos-    CActor aid l -> insertItemActor iid k l aid--posOfAid :: MonadActionRO m => ActorId -> m (LevelId, Point)-posOfAid aid = do-  b <- getsState $ getActorBody aid-  return (blid b, bpos b)--posOfContainer :: MonadActionRO m => Container -> m (LevelId, Point)-posOfContainer (CFloor lid p) = return (lid, p)-posOfContainer (CActor aid _) = posOfAid aid---- TODO: optimize (a single call to updatePrio is enough)-ageActorA :: MonadAction m => ActorId -> Time -> m ()-ageActorA aid t = assert (t /= timeZero) $ do-  body <- getsState $ getActorBody aid-  ais <- getsState $ getActorItem aid-  destroyActorA aid body ais-  let newBody = body {btime = timeAdd (btime body) t}-  createActorA aid newBody ais--healActorA :: MonadAction m => ActorId -> Int -> m ()-healActorA aid n = assert (n /= 0) $-  modifyState $ updateActorBody aid $ \b -> b {bhp = n + bhp b}--hasteActorA :: MonadAction m => ActorId -> Speed -> m ()-hasteActorA aid delta = assert (delta /= speedZero) $ do-  modifyState $ updateActorBody aid $ \ b ->-    let newSpeed = speedAdd (bspeed b) delta-    in assert (newSpeed >= speedZero-               `blame` "actor slowed below zero"-               `twith` (aid, delta, b, newSpeed))-       $ b {bspeed = newSpeed}--trajectoryActorA :: MonadAction m-           => ActorId -> Maybe [Vector] -> Maybe [Vector] -> m ()-trajectoryActorA 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-  modifyState $ updateActorBody aid $ \b -> b {btrajectory = toT}--colorActorA :: MonadAction m-            => ActorId -> Color.Color -> Color.Color -> m ()-colorActorA 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-  modifyState $ updateActorBody aid $ \b -> b {bcolor = toCol}--quitFactionA :: MonadAction m-             => FactionId -> Maybe Actor -> Maybe Status -> Maybe Status-             -> m ()-quitFactionA fid mbody fromSt toSt = assert (fromSt /= toSt) $ do-  assert (maybe True ((fid ==) . bfid) mbody) skip-  fact <- getsState $ (EM.! fid) . sfactionD-  assert (fromSt == gquit fact `blame` "unexpected actor quit status"-                               `twith` (fid, fromSt, toSt, fact)) skip-  let adj fa = fa {gquit = toSt}-  modifyState $ updateFaction $ EM.adjust adj fid---- The previous leader is assumed to be alive.-leadFactionA :: MonadAction m-             => FactionId -> Maybe ActorId -> Maybe ActorId -> m ()-leadFactionA fid source target = assert (source /= target) $ do-  fact <- getsState $ (EM.! fid) . sfactionD-  mtb <- getsState $ \s -> fmap (flip getActorBody s) target-  assert (maybe True (not . bproj) mtb-          `blame` (fid, source, target, mtb, fact)) skip-  assert (source == gleader fact `blame` "unexpected actor leader"-                                 `twith` (fid, source, target, mtb, fact)) skip-  let adj fa = fa {gleader = target}-  modifyState $ updateFaction $ EM.adjust adj fid--diplFactionA :: MonadAction m-             => FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()-diplFactionA fid1 fid2 fromDipl toDipl =-  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 adj fid fact = fact {gdipl = EM.insert fid toDipl (gdipl fact)}-    modifyState $ updateFaction $ EM.adjust (adj fid2) fid1-    modifyState $ updateFaction $ EM.adjust (adj fid1) fid2---- | Alter an attribute (actually, the only, the defining attribute)--- of a visible tile. This is similar to e.g., @TrajectoryActorA@.--- We do not modify @lclear@ here, because we can't keep track of--- alterations to unknown tiles. The server would need to send @lclear@--- updates for each invisible tile alteration that affects it.-alterTileA :: MonadAction m-           => LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind-           -> m ()-alterTileA lid p fromTile toTile = assert (fromTile /= toTile) $ do-  Kind.COps{cotile} <- getsState scops-  lvl <- getLevel lid-  let freshClientTile = hideTile cotile lvl p-  -- The second alternative can happen if, e.g., a client remembers,-  -- but does not see the tile (so does not notice the SearchTileA action),-  -- and it suddenly changes into another tile,-  -- which at the same time becomes visible (e.g., an open door).-  -- See 'AtomicSemCli' for how this is reported to the client.-  let adj ts = assert (ts PointArray.! p == fromTile-                       || ts PointArray.! p == freshClientTile-                       `blame` "unexpected altered tile kind"-                       `twith` (lid, p, fromTile, toTile, ts PointArray.! p))-               $ ts PointArray.// [(p, toTile)]-  updateLevel lid $ updateTile adj-  case (Tile.isExplorable cotile fromTile, Tile.isExplorable cotile toTile) of-    (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl + 1}-    (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl - 1}-    _ -> return ()---- Notice previously invisible tiles. This is similar to @SpotActorA@,--- but done in bulk, because it often involves dozens of tiles pers move.--- We don't check that the tiles at the positions in question are unknown--- to save computation, especially for clients that remember tiles--- at previously seen positions. Similarly, when updating the @lseen@--- field we don't assume the tiles were unknown previously.-spotTileA :: MonadAction m => LevelId -> [(Point, Kind.Id TileKind)] -> m ()-spotTileA lid ts = assert (not $ null ts) $ do-  Kind.COps{cotile} <- getsState scops-  Level{ltile} <- getLevel lid-  let adj tileMap = tileMap PointArray.// ts-  updateLevel lid $ updateTile adj-  let f (p, t2) = do-        let t1 = ltile PointArray.! p-        case (Tile.isExplorable cotile t1, Tile.isExplorable cotile t2) of-          (False, True) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl+1}-          (True, False) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl-1}-          _ -> return ()-  mapM_ f ts---- Stop noticing previously visible tiles. Unlike @spotTileA@, it verifies--- the state of the tiles before changing them.-loseTileA :: MonadAction m => LevelId -> [(Point, Kind.Id TileKind)] -> m ()-loseTileA lid ts = assert (not $ null ts) $ do-  Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops-  let unknownId = ouniqGroup "unknown space"-      matches _ [] = True-      matches tileMap ((p, ov) : rest) =-        tileMap PointArray.! p == ov && matches tileMap rest-      tu = map (second (const unknownId)) ts-      adj tileMap = assert (matches tileMap ts) $ tileMap PointArray.// tu-  updateLevel lid $ updateTile adj-  let f (_, t1) =-        when (Tile.isExplorable cotile t1) $-          updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1}-  mapM_ f ts--alterSmellA :: MonadAction m-            => LevelId -> Point -> Maybe Time -> Maybe Time -> m ()-alterSmellA lid p fromSm toSm = do-  let alt sm = assert (sm == fromSm `blame` "unexpected tile smell"-                                    `twith` (lid, p, fromSm, toSm, sm)) toSm-  updateLevel lid $ updateSmell $ EM.alter alt p--spotSmellA :: MonadAction m => LevelId -> [(Point, Time)] -> m ()-spotSmellA lid sms = assert (not $ null sms) $ do-  let alt sm Nothing = Just sm-      alt sm (Just oldSm) = assert `failure` "smell already added"-                                   `twith` (lid, sms, sm, oldSm)-      f (p, sm) = EM.alter (alt sm) p-      upd m = foldr f m sms-  updateLevel lid $ updateSmell upd--loseSmellA :: MonadAction m => LevelId -> [(Point, Time)] -> m ()-loseSmellA lid sms = assert (not $ null sms) $ do-  let alt sm Nothing = assert `failure` "smell already removed"-                              `twith` (lid, sms, sm)-      alt sm (Just oldSm) =-        assert (sm == oldSm `blame` "unexpected lost smell"-                            `twith` (lid, sms, sm, oldSm)) Nothing-      f (p, sm) = EM.alter (alt sm) p-      upd m = foldr f m sms-  updateLevel lid $ updateSmell upd---- | Age the level.------ Not aging the game here, since not all factions see the level,--- so not all get this command (it would lead information that--- there is somebody's leader on the level).-ageLevelA :: MonadAction m => LevelId -> Time -> m ()-ageLevelA lid delta = assert (delta /= timeZero) $-  updateLevel lid $ \lvl -> lvl {ltime = timeAdd (ltime lvl) delta}--ageGameA :: MonadAction m => Time -> m ()-ageGameA delta = assert (delta /= timeZero) $-  modifyState $ updateTime $ timeAdd delta--restartA :: MonadAction m-         => FactionId -> Discovery -> FactionPers -> State -> m ()-restartA _ _ _ = putState--restartServerA :: MonadAction m =>  State -> m ()-restartServerA = putState--resumeServerA :: MonadAction m =>  State -> m ()-resumeServerA = putState
− Game/LambdaHack/Common/ClientCmd.hs 
@@ -1,110 +0,0 @@--- | Abstract syntax of client commands.--- See--- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Common.ClientCmd-  ( CmdClientAI(..), CmdClientUI(..)-  , debugCmdClientAI, debugCmdClientUI, debugAid-  , ChanServer(..), ConnServerFaction, ConnServerDict-  ) where--import Control.Concurrent.STM.TQueue-import qualified Data.EnumMap.Strict as EM-import Data.Text (Text)-import qualified Data.Text as T--import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.AtomicCmd-import Game.LambdaHack.Common.AtomicPos-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.ServerCmd-import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Frontend---- | Abstract syntax of client commands that don't use the UI.-data CmdClientAI =-    CmdAtomicAI !CmdAtomic-  | CmdQueryAI !ActorId-  | CmdPingAI-  deriving Show---- | Abstract syntax of client commands that use the UI.-data CmdClientUI =-    CmdAtomicUI !CmdAtomic-  | SfxAtomicUI !SfxAtomic-  | CmdQueryUI !ActorId-  | CmdPingUI-  deriving Show--debugCmdClientAI :: MonadActionRO m => CmdClientAI -> m Text-debugCmdClientAI cmd = case cmd of-  CmdAtomicAI cmdA@PerceptionA{} -> debugPlain cmd cmdA-  CmdAtomicAI cmdA@ResumeA{} -> debugPlain cmd cmdA-  CmdAtomicAI cmdA@SpotTileA{} -> debugPlain cmd cmdA-  CmdAtomicAI cmdA -> debugPretty cmd cmdA-  CmdQueryAI aid -> debugAid aid "CmdQueryAI" cmd-  CmdPingAI -> return $! tshow cmd--debugCmdClientUI :: MonadActionRO m => CmdClientUI -> m Text-debugCmdClientUI cmd = case cmd of-  CmdAtomicUI cmdA@PerceptionA{} -> debugPlain cmd cmdA-  CmdAtomicUI cmdA@ResumeA{} -> debugPlain cmd cmdA-  CmdAtomicUI cmdA@SpotTileA{} -> debugPlain cmd cmdA-  CmdAtomicUI cmdA -> debugPretty cmd cmdA-  SfxAtomicUI sfx -> do-    ps <- posSfxAtomic sfx-    return $! tshow (cmd, ps)-  CmdQueryUI aid -> debugAid aid "CmdQueryUI" cmd-  CmdPingUI -> return $! tshow cmd--debugPretty :: (MonadActionRO m, Show a) => a -> CmdAtomic -> m Text-debugPretty cmd cmdA = do-  ps <- posCmdAtomic cmdA-  return $! tshow (cmd, ps)--debugPlain :: (MonadActionRO m, Show a) => a -> CmdAtomic -> m Text-debugPlain cmd cmdA = do-  ps <- posCmdAtomic cmdA-  return $! T.pack $ show (cmd, ps)  -- too large for pretty show--data DebugAid a = DebugAid-  { label   :: !Text-  , cmd     :: !a-  , lid     :: !LevelId-  , time    :: !Time-  , aid     :: !ActorId-  , faction :: !FactionId-  }-  deriving Show--debugAid :: (MonadActionRO m, Show a) => ActorId -> Text -> a -> m Text-debugAid aid label cmd =-  if aid == toEnum (-1) then-    return ""-  else do-    b <- getsState $ getActorBody aid-    time <- getsState $ getLocalTime (blid b)-    return $! tshow DebugAid { label-                             , cmd-                             , lid = blid b-                             , time-                             , aid-                             , faction = bfid b }---- | Connection channels between the server and a single client.-data ChanServer c d = ChanServer-  { fromServer :: !(TQueue c)-  , toServer   :: !(TQueue d)-  }---- | Connections to the human-controlled client of a faction and--- to the AI client for the same faction.-type ConnServerFaction = ( Maybe (ChanFrontend, ChanServer CmdClientUI CmdSer)-                         , ChanServer CmdClientAI CmdTakeTimeSer )---- | Connection information for all factions, indexed by faction identifier.-type ConnServerDict = EM.EnumMap FactionId ConnServerFaction
+ Game/LambdaHack/Common/ClientOptions.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Screen frames and animations.+module Game.LambdaHack.Common.ClientOptions+  ( DebugModeCli(..), defDebugModeCli+  ) where++import Data.Binary+import GHC.Generics (Generic)++import Game.LambdaHack.Common.Faction++data DebugModeCli = DebugModeCli+  { sfont          :: !(Maybe String)+      -- ^ Font to use for the main game window.+  , smaxFps        :: !(Maybe Int)+      -- ^ Maximal frames per second.+      -- This is better low and fixed, to avoid jerkiness and delays+      -- that tell the player there are many intelligent enemies on the level.+      -- That's better than scaling AI sofistication down based+      -- on the FPS setting and machine speed.+  , snoDelay       :: !Bool+      -- ^ Don't maintain any requested delays between frames,+      -- e.g., for screensaver.+  , snoMore        :: !Bool+      -- ^ Auto-answer all prompts, e.g., for screensaver.+  , snoAnim        :: !(Maybe Bool)+      -- ^ Don't show any animations.+  , snewGameCli    :: !Bool+      -- ^ Start a new game, overwriting the save file.+  , sdifficultyCli :: !Int+      -- ^ The difficulty level for all UI clients.+  , ssavePrefixCli :: !(Maybe String)+      -- ^ Prefix of the save game file.+  , sfrontendStd   :: !Bool+      -- ^ Whether to use the stdout/stdin frontend for all clients.+  , sfrontendNull  :: !Bool+      -- ^ Whether to use void (no input/output) frontend for all clients.+  , sdbgMsgCli     :: !Bool+      -- ^ Show clients' internal debug messages.+  }+  deriving (Show, Eq, Generic)++instance Binary DebugModeCli++defDebugModeCli :: DebugModeCli+defDebugModeCli = DebugModeCli+  { sfont = Nothing+  , smaxFps = Nothing+  , snoDelay = False+  , snoMore = False+  , snoAnim = Nothing+  , snewGameCli = False+  , sdifficultyCli = difficultyDefault+  , ssavePrefixCli = Nothing+  , sfrontendStd = False+  , sfrontendNull = False+  , sdbgMsgCli = False+  }
Game/LambdaHack/Common/Color.hs view
@@ -10,7 +10,7 @@  import Data.Binary import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.))-import qualified Data.Hashable as Hashable+import Data.Hashable (Hashable) import GHC.Generics (Generic)  -- TODO: since this type may be essential to speed, consider implementing@@ -38,7 +38,7 @@   | BrWhite   deriving (Show, Eq, Ord, Enum, Bounded, Generic) -instance Hashable.Hashable Color+instance Hashable Color  -- | The default colours, to optimize attribute setting. defBG, defFG :: Color@@ -129,21 +129,3 @@ instance Binary Color where   put = putWord8 . toEnum . fromEnum   get = fmap (toEnum . fromEnum) getWord8--instance Binary Attr where-  put Attr{..} = do-    put fg-    put bg-  get = do-    fg <- get-    bg <- get-    return $! Attr{..}--instance Binary AttrChar where-  put AttrChar{..} = do-    put acAttr-    put acChar-  get = do-    acAttr <- get-    acChar <- get-    return $! AttrChar{..}
+ Game/LambdaHack/Common/Dice.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE DeriveGeneric, FlexibleInstances, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- | 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, (|*|)+  , d, z, dl, zl, intToDice+  , maxDice, minDice, meanDice, reduceDice+    -- * Dice for rolling a pair of integer parameters representing coordinates.+  , DiceXY(..), maxDiceXY, minDiceXY, meanDiceXY+  ) where++import Control.Applicative+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.Text (Text)+import qualified Data.Text as T+import Data.Tuple+import GHC.Generics (Generic)++import Game.LambdaHack.Common.Frequency+import Game.LambdaHack.Common.Msg++type SimpleDice = Frequency Int++normalizeSimple :: SimpleDice -> SimpleDice+normalizeSimple fr = toFreq (nameFrequency fr)+                     $ map swap $ IM.toAscList $ IM.fromListWith (+)+                     $ map swap $ runFrequency fr++-- Normalized mainly as an optimization, but it also makes many expected+-- algeraic laws hold (wrt @Eq@), except for some laws about+-- multiplication. We use @liftA2@ instead of @liftM2@, because it's probably+-- faster in this case.+instance Num SimpleDice where+  fr1 + fr2 = normalizeSimple $ liftA2AdditiveName "+" (+) fr1 fr2+  fr1 * fr2 =+    let frRes = normalizeSimple $ do+          n <- fr1+          sum $ replicate n fr2  -- not commutative!+        nameRes =+          case T.uncons $ nameFrequency fr2 of+            _ | nameFrequency fr1 == "0" || nameFrequency fr2 == "0" -> "0"+            Just ('d', _) | T.all Char.isDigit $ nameFrequency fr1 ->+              nameFrequency fr1 <> nameFrequency fr2+            _ -> nameFrequency fr1 <+> "*" <+> nameFrequency fr2+    in renameFreq nameRes frRes+  fr1 - fr2 = normalizeSimple $ liftA2AdditiveName "-" (-) fr1 fr2+  negate = liftAName "-" negate+  abs = normalizeSimple . liftAName "abs" abs+  signum = normalizeSimple . liftAName "signum" signum+  fromInteger n = renameFreq (tshow n) $ pure $ fromInteger n++liftAName :: Text -> (Int -> Int) -> SimpleDice -> SimpleDice+liftAName name f fr =+  let frRes = liftA f fr+      nameRes = name <> " (" <> nameFrequency fr  <> ")"+  in renameFreq nameRes frRes++liftA2AdditiveName :: Text+                   -> (Int -> Int -> Int)+                   -> SimpleDice -> SimpleDice -> SimpleDice+liftA2AdditiveName name f fra frb =+  let frRes = liftA2 f fra frb+      nameRes =+        if nameFrequency fra == "0" then nameFrequency frb+        else if nameFrequency frb == "0" then nameFrequency fra+        else nameFrequency fra <+> name <+> nameFrequency frb+  in renameFreq nameRes frRes++dieSimple :: Int -> SimpleDice+dieSimple n = uniformFreq ("d" <> tshow n) [1..n]++zdieSimple :: Int -> SimpleDice+zdieSimple n = uniformFreq ("z" <> tshow n) [0..n-1]++-- | Dice for parameters scaled with current level depth.+-- To the result of rolling the first set of dice we add the second,+-- scaled in proportion to current depth divided by maximal dungeon depth.+-- The result if then multiplied by the scale --- to be used to ensure+-- that dice results are multiples of, e.g., 10. The scale is set with @|*|@.+data Dice = Dice+  { diceConst :: SimpleDice+  , diceLevel :: SimpleDice+  , diceScale :: Int+  }+  deriving (Read, Eq, Ord, Generic)++instance Show Dice where+  show Dice{..} = T.unpack $+    let scaled = "scaled(" <> nameFrequency diceLevel <> ")"+    in (if nameFrequency diceLevel == "0" then nameFrequency diceConst+        else if nameFrequency diceConst == "0" then scaled+        else nameFrequency diceConst <+> "+" <+> scaled)+       <+> if diceScale == 1 then "" else "|*|" <+> tshow diceScale++instance Hashable Dice++instance Binary Dice++instance Num Dice where+  (Dice dc1 dl1 ds1) + (Dice dc2 dl2 ds2) =+    Dice (scaleFreq ds1 dc1 + scaleFreq ds2 dc2)+         (scaleFreq ds1 dl1 + scaleFreq ds2 dl2)+         1+  (Dice dc1 dl1 ds1) * (Dice dc2 dl2 ds2) =+    -- Hacky, but necessary (unless we forgo general multiplication and+    -- stick to multiplications by a scalar from the left and from the right).+    -- The pseudo-reasoning goes (remember the multiplication+    -- is not commutative, so we take all kinds of liberties):+    -- (dc1 + dl1 * l) * (dc2 + dl2 * l)+    -- = dc1 * dc2 + dc1 * dl2 * l + dl1 * l * dc2 + dl1 * l * dl2 * l+    -- = dc1 * dc2 + (dc1 * dl2) * l + (dl1 * dc2) * l + (dl1 * dl2) * l * l+    -- Now, we don't have a slot to put the coefficient of l * l into+    -- (and we don't know l yet, so we can't eliminate it by division),+    -- so we happily ignore it. Done. It works well in the cases that interest+    -- us, that is, multiplication by a scalar (a one-element frequency+    -- distribution) from any side, unscaled and scaled by level depth+    -- (but when we multiply two scaled scalars, we get 0).+    Dice (scaleFreq ds1 dc1 * scaleFreq ds2 dc2)+         (scaleFreq ds1 dc1 * scaleFreq ds2 dl2+          + scaleFreq ds1 dl1 * scaleFreq ds2 dc2)+         1+  (Dice dc1 dl1 ds1) - (Dice dc2 dl2 ds2) =+    Dice (scaleFreq ds1 dc1 - scaleFreq ds2 dc2)+         (scaleFreq ds1 dl1 - scaleFreq ds2 dl2)+         1+  negate = affectBothDice negate+  abs = affectBothDice abs+  signum = affectBothDice signum+  fromInteger n = Dice (fromInteger n) (fromInteger 0) 1++affectBothDice :: (SimpleDice -> SimpleDice) -> Dice -> Dice+affectBothDice f (Dice dc1 dl1 ds1) = Dice (f dc1) (f dl1) ds1++d :: Int -> Dice+d n = Dice (dieSimple n) (fromInteger 0) 1++z :: Int -> Dice+z n = Dice (zdieSimple n) (fromInteger 0) 1++dl :: Int -> Dice+dl n = Dice (fromInteger 0) (dieSimple n) 1++zl :: Int -> Dice+zl n = Dice (fromInteger 0) (zdieSimple n) 1++intToDice :: Int -> Dice+intToDice = fromInteger . fromIntegral++(|*|) :: 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++-- | Minimal value of dice. The scaled part ignored.+-- Assumes the frequencies are not null.+minDice :: Dice -> Int+minDice Dice{..} = minFreq diceConst * diceScale++-- | Mean value of dice. The scaled part taken assuming average level.+-- Assumes the frequencies are not null.+meanDice :: Dice -> Rational+meanDice Dice{..} = meanFreq diceConst * fromIntegral diceScale+                    + meanFreq diceLevel * fromIntegral diceScale * (1%2)++reduceDice :: Dice -> Maybe Int+reduceDice de = if minDice de == maxDice de then Just (minDice de) else Nothing++-- | Dice for rolling a pair of integer parameters pertaining to,+-- respectively, the X and Y cartesian 2D coordinates.+data DiceXY = DiceXY !Dice !Dice+  deriving (Show, Eq, Ord, Generic)++instance Hashable DiceXY++instance Binary DiceXY++-- | Maximal value of DiceXY.+maxDiceXY :: DiceXY -> (Int, Int)+maxDiceXY (DiceXY x y) = (maxDice x, maxDice y)++-- | Minimal value of DiceXY.+minDiceXY :: DiceXY -> (Int, Int)+minDiceXY (DiceXY x y) = (minDice x, minDice y)++-- | Mean value of DiceXY.+meanDiceXY :: DiceXY -> (Rational, Rational)+meanDiceXY (DiceXY x y) = (meanDice x, meanDice y)
Game/LambdaHack/Common/Effect.hs view
@@ -1,99 +1,215 @@ {-# LANGUAGE DeriveFunctor, DeriveGeneric #-}--- | Effects of content on other content. No operation in this module--- involves the 'State' or 'Action' type.+-- | Effects of content on the game state. No operation in this module+-- involves state or monad types. module Game.LambdaHack.Common.Effect-  ( Effect(..), effectTrav, effectToSuffix+  ( Effect(..), Aspect(..), ThrowMod(..), Feature(..), EqpSlot(..)+  , effectTrav, aspectTrav   ) where -import Control.Exception.Assert.Sugar import qualified Control.Monad.State as St import Data.Binary-import qualified Data.Hashable as Hashable+import Data.Hashable (Hashable) import Data.Text (Text) import GHC.Generics (Generic) -import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Random+import qualified Game.LambdaHack.Common.Ability as Ability+import qualified Game.LambdaHack.Common.Dice as Dice+import Game.LambdaHack.Common.Misc  -- TODO: document each constructor--- Effects of items, tiles, etc. The type argument represents power.--- either as a random formula dependent on level, or as a final rolled value.+-- | Effects of items. Can be invoked by the item wielder to affect+-- another actor or the wielder himself. Many occurences in the same item+-- are possible. data Effect a =-    NoEffect-  | Heal !Int-  | Hurt !RollDice !a-  | Mindprobe Int    -- the @Int@ is a lazy hack to send the result to clients+    NoEffect !Text+  | Hurt !Dice.Dice+  | Burn !Int+  | Explode !Text         -- ^ explode, producing this group of shrapnel+  | RefillHP !Int+  | RefillCalm !Int   | Dominate-  | CallFriend !Int-  | Summon !Int-  | CreateItem !Int-  | ApplyPerfume-  | Regeneration !a-  | Searching !a+  | Impress+  | CallFriend !a+  | Summon !Freqs !a+  | CreateItem !a   | Ascend !Int-  | Escape !Int+  | Escape !Int           -- ^ the Int says if can be placed on last level, etc.+  | Paralyze !a+  | InsertMove !a+  | Teleport !a+  | PolyItem !CStore+  | Identify !CStore+  | SendFlying !ThrowMod+  | PushActor !ThrowMod+  | PullActor !ThrowMod+  | DropBestWeapon+  | DropEqp !Char !Bool   -- ^ symbol @' '@ means all, @True@ means hit on drop+  | ActivateInv !Char     -- ^ symbol @' '@ means all+  | ApplyPerfume+  | OneOf ![Effect a]+  | OnSmash !(Effect a)   -- ^ trigger if item smashed (not applied nor meleed)+  | TimedAspect !Int !(Aspect a)+                          -- ^ enable the aspect for k clips   deriving (Show, Read, Eq, Ord, Generic, Functor) -instance Hashable.Hashable a => Hashable.Hashable (Effect a)+-- | Aspects of items. Additive (starting at 0) for all items wielded+-- by an actor and affect the actor (except @Periodic@ that only affect+-- the item and so is not additive).+data Aspect a =+    Periodic !a        -- ^ is activated this many times in 100+  | AddHurtMelee !a    -- ^ percentage damage bonus in melee+  | AddArmorMelee !a   -- ^ percentage armor bonus against melee+  | AddHurtRanged !a   -- ^ percentage damage bonus in ranged+  | AddArmorRanged !a  -- ^ percentage armor bonus against ranged+  | AddMaxHP !a        -- ^ maximal hp+  | AddMaxCalm !a      -- ^ maximal calm+  | AddSpeed !a        -- ^ speed in m/10s+  | AddSkills !Ability.Skills  -- ^ skills in particular abilities+  | 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) +-- | Parameters modifying a throw. Not additive and don't start at 0.+data ThrowMod = ThrowMod+  { throwVelocity :: !Int  -- ^ fly with this percentage of base throw speed+  , throwLinger   :: !Int  -- ^ fly for this percentage of 2 turns+  }+  deriving (Show, Read, Eq, Ord, Generic)++-- | Features of item. Affect only the item in question, not the actor,+-- and so not additive in any sense.+data Feature =+    ChangeTo !Text           -- ^ change to this group when altered+  | Fragile                  -- ^ break even when not hitting an enemy+  | Durable                  -- ^ don't break even hitting or applying+  | ToThrow !ThrowMod        -- ^ parameters modifying a throw+  | Identified               -- ^ the item starts identified+  | Applicable               -- ^ AI and uI flag: consider applying+  | EqpSlot !EqpSlot !Text   -- ^ AI and uI flag: goes to inventory+  | Precious                 -- ^ AI and UI flag: careful, can be precious;+                             --   don't risk identifying by use+  deriving (Show, Eq, Ord, Generic)++data EqpSlot =+    EqpSlotPeriodic+  | EqpSlotAddHurtMelee+  | EqpSlotAddArmorMelee+  | EqpSlotAddHurtRanged+  | EqpSlotAddArmorRanged+  | EqpSlotAddMaxHP+  | EqpSlotAddMaxCalm+  | EqpSlotAddSpeed+  | EqpSlotAddSkills+  | EqpSlotAddSight+  | EqpSlotAddSmell+  | EqpSlotAddLight+  | EqpSlotWeapon+  deriving (Show, Eq, Ord, Generic)++instance Hashable a => Hashable (Effect a)++instance Hashable a => Hashable (Aspect a)++instance Hashable ThrowMod++instance Hashable Feature++instance Hashable EqpSlot+ instance Binary a => Binary (Effect a) +instance Binary a => Binary (Aspect a)++instance Binary ThrowMod++instance Binary Feature++instance Binary EqpSlot+ -- TODO: Traversable? -- | Transform an effect using a stateful function. effectTrav :: Effect a -> (a -> St.State s b) -> St.State s (Effect b)-effectTrav NoEffect _ = return NoEffect-effectTrav (Heal p) _ = return $! Heal p-effectTrav (Hurt dice a) f = do-  b <- f a-  return $! Hurt dice b-effectTrav (Mindprobe x) _ = return $! Mindprobe x+effectTrav (NoEffect t) _ = return $! NoEffect t+effectTrav (RefillHP p) _ = return $! RefillHP p+effectTrav (Hurt dice) _ = return $! Hurt dice+effectTrav (RefillCalm p) _ = return $! RefillCalm p effectTrav Dominate _ = return Dominate-effectTrav (CallFriend p) _ = return $! CallFriend p-effectTrav (Summon p) _ = return $! Summon p-effectTrav (CreateItem p) _ = return $! CreateItem p-effectTrav ApplyPerfume _ = return ApplyPerfume-effectTrav (Regeneration a) f = do+effectTrav Impress _ = return Impress+effectTrav (CallFriend a) f = do   b <- f a-  return $! Regeneration b-effectTrav (Searching a) f = do+  return $! CallFriend b+effectTrav (Summon freqs a) f = do   b <- f a-  return $! Searching b+  return $! Summon freqs b+effectTrav (CreateItem a) f = do+  b <- f a+  return $! CreateItem b+effectTrav ApplyPerfume _ = return ApplyPerfume+effectTrav (Burn p) _ = return $! Burn p effectTrav (Ascend p) _ = return $! Ascend p effectTrav (Escape p) _ = return $! Escape p---- | Suffix to append to a basic content name if the content causes the effect.-effectToSuff :: Show a => Effect a -> (a -> Text) -> Text-effectToSuff effect f =-  case St.evalState (effectTrav effect $ return . f) () of-    NoEffect -> ""-    Heal p | p > 0 -> "of healing" <> affixBonus p-    Heal 0 -> "of bloodletting"-    Heal p -> "of wounding" <> affixBonus p-    Hurt dice t -> "(" <> tshow dice <> ")" <> t-    Mindprobe{} -> "of soul searching"-    Dominate -> "of domination"-    CallFriend p -> "of aid calling" <> affixPower p-    Summon p -> "of summoning" <> affixPower p-    CreateItem p -> "of item creation" <> affixPower p-    ApplyPerfume -> "of rose water"-    Regeneration t -> "of regeneration" <> t-    Searching t -> "of searching" <> t-    Ascend p | p > 0 -> "of ascending" <> affixPower p-    Ascend p | p < 0 -> "of descending" <> affixPower (- p)-    Ascend{} -> assert `failure` effect-    Escape{} -> "of escaping"--effectToSuffix :: Effect Int -> Text-effectToSuffix effect = effectToSuff effect affixBonus--affixPower :: Int -> Text-affixPower p = case compare p 1 of-  EQ -> ""-  LT -> assert `failure` "power less than 1" `twith` p-  GT -> " (+" <> tshow p <> ")"+effectTrav (Paralyze a) f = do+  b <- f a+  return $! Paralyze b+effectTrav (InsertMove a) f = do+  b <- f a+  return $! InsertMove b+effectTrav DropBestWeapon _ = return DropBestWeapon+effectTrav (DropEqp symbol hit) _ = return $! DropEqp symbol hit+effectTrav (SendFlying tmod) _ = return $! SendFlying tmod+effectTrav (PushActor tmod) _ = return $! PushActor tmod+effectTrav (PullActor tmod) _ = return $! PullActor tmod+effectTrav (Teleport a) f = do+  b <- f a+  return $! Teleport b+effectTrav (PolyItem cstore) _ = return $! PolyItem cstore+effectTrav (Identify cstore) _ = return $! Identify cstore+effectTrav (ActivateInv symbol) _ = return $! ActivateInv symbol+effectTrav (OneOf la) f = do+  lb <- mapM (\a -> effectTrav a f) la+  return $! OneOf lb+effectTrav (OnSmash effa) f = do+  effb <- effectTrav effa f+  return $! OnSmash effb+effectTrav (Explode t) _ = return $! Explode t+effectTrav (TimedAspect k asp) f = do+  asp2 <- aspectTrav asp f+  return $! TimedAspect k asp2 -affixBonus :: Int -> Text-affixBonus p = case compare p 0 of-  EQ -> ""-  LT -> " (" <> tshow p <> ")"-  GT -> " (+" <> tshow p <> ")"+-- | Transform an aspect using a stateful function.+aspectTrav :: Aspect a -> (a -> St.State s b) -> St.State s (Aspect b)+aspectTrav (Periodic a) f = do+  b <- f a+  return $! Periodic 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
+ Game/LambdaHack/Common/EffectDescription.hs view
@@ -0,0 +1,162 @@+-- | Description of effects. No operation in this module+-- involves state or monad types.+module Game.LambdaHack.Common.EffectDescription+  ( effectToSuffix, aspectToSuffix, featureToSuff+  , kindEffectToSuffix, kindAspectToSuffix+  ) 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 (ppCStore)+import qualified Game.LambdaHack.Common.Dice as Dice+import Game.LambdaHack.Common.Effect+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Time++-- | Suffix to append to a basic content name if the content causes the effect.+effectToSuff :: (Show a, Ord a, Num a)+             => Effect a -> (a -> Text) -> (a -> Maybe Int) -> Text+effectToSuff effect f g =+  case ( St.evalState (effectTrav effect $ return . f) ()+       , St.evalState (effectTrav effect $ return . g) () ) of+    (NoEffect t, _) -> t+    (RefillHP p, _) | p > 0 -> "of healing" <+> wrapInParens (affixBonus p)+    (RefillHP 0, _) -> assert `failure` effect+    (RefillHP p, _) -> "of wounding" <+> wrapInParens (affixBonus p)+    (Hurt dice, _) -> wrapInParens (tshow dice)+    (RefillCalm p, _) | p > 0 -> "of soothing" <+> wrapInParens (affixBonus p)+    (RefillCalm 0, _) -> assert `failure` effect+    (RefillCalm p, _) -> "of dismaying" <+> wrapInParens (affixBonus p)+    (Dominate, _) -> "of domination"+    (Impress, _) -> "of impression"+    (_, CallFriend (Just 1)) -> "of aid calling"+    (CallFriend t, _) -> "of aid calling"+                         <+> wrapInParens (dropPlus t <+> "friends")+    (_, Summon _freqs (Just 1)) -> "of summoning"  -- TODO+    (Summon _freqs t, _) -> "of summoning"+                            <+> wrapInParens (dropPlus t <+> "actors")+    (_, CreateItem (Just 1)) -> "of uncovering"+    (CreateItem t, _) -> "of uncovering"+                         <+> wrapInParens (dropPlus t <+> "items")+    (ApplyPerfume, _) -> "of smell removal"+    (Burn p, _) | p <= 0 -> assert `failure` effect+    (Burn p, _) -> wrapInParens (makePhrase [MU.CarWs p "burn"])+    (Ascend 1, _) -> "of ascending"+    (Ascend p, _) | p > 0 ->+      "of ascending" <+> wrapInParens (tshow p <+> "levels")+    (Ascend 0, _) -> assert `failure` effect+    (Ascend (-1), _) -> "of descending"+    (Ascend p, _) ->+      "of descending" <+> wrapInParens (tshow (-p) <+> "levels")+    (Escape{}, _) -> "of escaping"+    (_, Paralyze Nothing) -> "of paralysis (? clips)"+    (_, Paralyze (Just p)) ->+      let clipInTurn = timeTurn `timeFit` timeClip+          seconds = 0.5 * fromIntegral p / fromIntegral clipInTurn :: Double+      in "of paralysis" <+> wrapInParens (tshow seconds <> "s")+    (_, InsertMove Nothing) ->+      "of speed surge (? moves)"+    (_, InsertMove (Just p)) ->+      "of speed surge" <+> wrapInParens (makePhrase [MU.CarWs p "move"])+    (DropBestWeapon, _) -> "of disarming"+    (DropEqp ' ' False, _) -> "of equipment drop"+    (DropEqp symbol False, _) -> "of drop '" <> T.singleton symbol <> "'"+    (DropEqp ' ' True, _) -> "of equipment smash"+    (DropEqp symbol True, _) -> "of smash '" <> T.singleton symbol <> "'"+    (SendFlying tmod, _) -> "of impact" <+> tmodToSuff "" tmod+    (PushActor tmod, _) -> "of pushing" <+> tmodToSuff "" tmod+    (PullActor tmod, _) -> "of pulling" <+> tmodToSuff "" tmod+    (_, Teleport (Just p)) | p <= 1  -> assert `failure` effect+    (Teleport t, Teleport (Just p)) | p <= 9  ->+      "of blinking" <+> wrapInParens (dropPlus t <+> "steps")+    (Teleport t, _)->+      "of teleport" <+> wrapInParens (dropPlus t <+> "steps")+    (PolyItem _cstore, _) -> "of repurpose"  -- <+> ppCStore cstore+    (Identify _cstore, _) -> "of identify"  -- <+> ppCStore cstore+    (ActivateInv ' ', _) -> "of inventory burst"+    (ActivateInv symbol, _) -> "of burst '" <> T.singleton symbol <> "'"+    (Explode _, _) -> "of explosion"  -- TODO: first word + explosion? nothing?+    (OneOf l, _) ->+      let subject = if length l <= 5 then "marvel" else "wonder"+      in makePhrase ["of", MU.CardinalWs (length l) subject]+    (OnSmash _, _) -> ""  -- conditional effect, TMI+    (TimedAspect _ aspect, _) -> "keep (" <> rawAspectToSuff aspect <> ")"+    (effectF, effectG) -> assert `failure` (effect, effectF, effectG)++tmodToSuff :: Text -> ThrowMod -> Text+tmodToSuff verb ThrowMod{..} =+  let vSuff | throwVelocity == 100 = ""+            | otherwise = "v=" <> tshow throwVelocity <> "%"+      tSuff | throwLinger == 100 = ""+            | otherwise = "t=" <> tshow throwLinger <> "%"+  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+    Periodic t -> wrapInParens $ dropPlus t <+> "in 100"+    AddMaxHP t -> wrapInParens $ t <+> "HP"+    AddMaxCalm t -> wrapInParens $ t <+> "Calm"+    AddSpeed t -> wrapInParens $ t <+> "speed"+    AddSkills p -> wrapInParens $ "+" <+> tshow (EM.toList p)+    AddHurtMelee t -> wrapInParens $ t <> "% melee"+    AddHurtRanged  t -> wrapInParens $ t <> "% ranged"+    AddArmorMelee t -> "[" <> t <> "%]"+    AddArmorRanged t -> "{" <> t <> "%}"+    AddSight t -> wrapInParens $ t <+> "sight"+    AddSmell t -> wrapInParens $ t <+> "smell"+    AddLight t -> wrapInParens $ t <+> "light"++featureToSuff :: Feature -> Text+featureToSuff feat =+  case feat of+    ChangeTo t -> wrapInChevrons $ "changes to" <+> t+    Fragile -> wrapInChevrons $ "fragile"+    Durable -> wrapInChevrons $ "durable"+    ToThrow tmod -> wrapInChevrons $ tmodToSuff "flies" tmod+    Identified -> ""+    Applicable -> ""+    EqpSlot{} -> ""+    Precious -> ""++dropPlus :: Text -> Text+dropPlus = T.dropWhile (`elem` ['+', '-'])++effectToSuffix :: Effect Int -> Text+effectToSuffix effect = effectToSuff effect affixBonus Just++aspectToSuffix :: Aspect Int -> Text+aspectToSuffix aspect = aspectToSuff aspect affixBonus++affixBonus :: Int -> Text+affixBonus p = case compare p 0 of+  EQ -> ""+  LT -> tshow p+  GT -> "+" <> tshow p++wrapInParens :: Text -> Text+wrapInParens "" = ""+wrapInParens t = "(" <> t <> ")"++wrapInChevrons :: Text -> Text+wrapInChevrons "" = ""+wrapInChevrons t = "<" <> t <> ">"++affixDice :: Dice.Dice -> Text+affixDice d = maybe "+?" affixBonus $ Dice.reduceDice d++kindEffectToSuffix :: Effect Dice.Dice -> Text+kindEffectToSuffix effect = effectToSuff effect affixDice Dice.reduceDice++kindAspectToSuffix :: Aspect Dice.Dice -> Text+kindAspectToSuffix aspect = aspectToSuff aspect affixDice
Game/LambdaHack/Common/Faction.hs view
@@ -2,31 +2,38 @@ -- the hero faction battling the monster and the animal factions. module Game.LambdaHack.Common.Faction   ( FactionId, FactionDict, Faction(..), Diplomacy(..), Outcome(..), Status(..)-  , isHeroFact, isHorrorFact, isSpawnFact, isSummonFact, isAtWar, isAllied+  , isHeroFact, isCivilianFact, isHorrorFact, isSpawnFact, isSummonFact+  , isAllMoveFact, keepArenaFact, isAtWar, isAllied+  , difficultyBound, difficultyDefault, difficultyCoeff   ) where  import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Text (Text) +import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Color as Color+import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.FactionKind+import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.ModeKind  -- | All factions in the game, indexed by faction identifier. type FactionDict = EM.EnumMap FactionId Faction  data Faction = Faction-  { gkind   :: !(Kind.Id FactionKind)  -- ^ the kind of the faction-  , gname   :: !Text                   -- ^ individual name-  , gcolor  :: !Color.Color            -- ^ color of actors or their frames-  , gplayer :: !Player                 -- ^ the player spec for this faction-  , gdipl   :: !Dipl                   -- ^ diplomatic mode-  , gquit   :: !(Maybe Status)         -- ^ cause of game end/exit-  , gleader :: !(Maybe ActorId)        -- ^ the leader of the faction, if any+  { gkind    :: !(Kind.Id FactionKind)  -- ^ the kind of the faction+  , gname    :: !Text                   -- ^ individual name+  , gcolor   :: !Color.Color            -- ^ color of actors or their frames+  , gplayer  :: !Player                 -- ^ the player spec for this faction+  , gdipl    :: !Dipl                   -- ^ diplomatic mode+  , gquit    :: !(Maybe Status)         -- ^ cause of game end/exit+  , gleader  :: !(Maybe ActorId)        -- ^ the leader of the faction, if any+  , gsha     :: !ItemBag                -- ^ faction's shared inventory+  , gvictims :: !(EM.EnumMap (Kind.Id ItemKind) Int)  -- ^ members killed   }   deriving (Show, Eq) @@ -36,7 +43,7 @@   | Neutral   | Alliance   | War-  deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord, Enum)  type Dipl = EM.EnumMap FactionId Diplomacy @@ -48,7 +55,7 @@   | Conquer   -- ^ the player won by eliminating all rivals   | Escape    -- ^ the player escaped the dungeon alive   | Restart   -- ^ game is restarted-  deriving (Show, Eq, Ord)+  deriving (Show, Eq, Ord, Enum)  -- | Current game status. data Status = Status@@ -59,10 +66,14 @@   deriving (Show, Eq, Ord)  -- | Tell whether the faction consists of heroes.-isHeroFact :: Kind.COps -> Faction -> Bool-isHeroFact Kind.COps{cofaction=Kind.Ops{okind}} fact =+isHeroFact :: Faction -> Bool+isHeroFact fact = playerIsHero (gplayer fact)++-- | Tell whether the faction consists of human civilians.+isCivilianFact :: Kind.COps -> Faction -> Bool+isCivilianFact Kind.COps{cofaction=Kind.Ops{okind}} fact =   let kind = okind (gkind fact)-  in maybe False (> 0) $ lookup "hero" $ ffreq kind+  in maybe False (> 0) $ lookup "civilian" $ ffreq kind  -- | Tell whether the faction consists of summoned horrors only. isHorrorFact :: Kind.COps -> Faction -> Bool@@ -70,9 +81,10 @@   let kind = okind (gkind fact)   in maybe False (> 0) $ lookup "horror" $ ffreq kind --- | Tell whether the faction can spawn actors.+-- | Tell whether the faction is considered permanent dungeon dwellers+-- (normally these are just spawning factions, but there are exceptions). isSpawnFact :: Faction -> Bool-isSpawnFact fact = playerSpawn (gplayer fact) > 0+isSpawnFact fact = playerIsSpawn (gplayer fact)  -- | Tell whether actors of the faction can be summoned by items, etc. isSummonFact :: Kind.COps -> Faction -> Bool@@ -80,6 +92,24 @@   let kind = okind (gkind fact)   in maybe False (> 0) $ lookup "summon" $ ffreq kind +-- | Tell whether all moving actors of the factions can move at once.+isAllMoveFact :: Kind.COps -> Faction -> Bool+isAllMoveFact Kind.COps{cofaction=Kind.Ops{okind}} fact =+  let kind = okind (gkind fact)+      skillsLeader = fSkillsLeader kind+      skillsOther = fSkillsOther kind+  in EM.findWithDefault 0 Ability.AbMove skillsLeader > 0+     && EM.findWithDefault 0 Ability.AbMove skillsOther > 0++-- | Tell whether a faction that we know is still in game, keeps arena.+-- Such factions win if they can escape the dungeon.+-- Keeping arena means, if the faction is still in game,+-- it always has a leader in the dungeon somewhere.+-- So, leaderless factions and spawner factions do not keep an arena,+-- even though the latter usually has a leader for most of the game.+keepArenaFact :: Faction -> Bool+keepArenaFact fact = playerLeader (gplayer fact) && not (isSpawnFact fact)+ -- | Check if factions are at war. Assumes symmetry. isAtWar :: Faction -> FactionId -> Bool isAtWar fact fid = War == EM.findWithDefault Unknown fid (gdipl fact)@@ -88,6 +118,16 @@ isAllied :: Faction -> FactionId -> Bool isAllied fact fid = Alliance == EM.findWithDefault Unknown fid (gdipl fact) +difficultyBound :: Int+difficultyBound = 9++difficultyDefault :: Int+difficultyDefault = (1 + difficultyBound) `div` 2++-- The function is its own inverse.+difficultyCoeff :: Int -> Int+difficultyCoeff n = difficultyDefault - n+ instance Binary Faction where   put Faction{..} = do     put gkind@@ -97,6 +137,8 @@     put gdipl     put gquit     put gleader+    put gsha+    put gvictims   get = do     gkind <- get     gname <- get@@ -105,39 +147,17 @@     gdipl <- get     gquit <- get     gleader <- get+    gsha <- get+    gvictims <- get     return $! Faction{..}  instance Binary Diplomacy where-  put Unknown  = putWord8 0-  put Neutral  = putWord8 1-  put Alliance = putWord8 2-  put War      = putWord8 3-  get = do-    tag <- getWord8-    case tag of-      0 -> return Unknown-      1 -> return Neutral-      2 -> return Alliance-      3 -> return War-      _ -> fail "no parse (Diplomacy)"+  put = putWord8 . toEnum . fromEnum+  get = fmap (toEnum . fromEnum) getWord8  instance Binary Outcome where-  put Killed = putWord8 0-  put Defeated = putWord8 1-  put Camping = putWord8 2-  put Conquer = putWord8 3-  put Escape = putWord8 4-  put Restart = putWord8 5-  get = do-    tag <- getWord8-    case tag of-      0 -> return Killed-      1 -> return Defeated-      2 -> return Camping-      3 -> return Conquer-      4 -> return Escape-      5 -> return Restart-      _ -> fail "no parse (Outcome)"+  put = putWord8 . toEnum . fromEnum+  get = fmap (toEnum . fromEnum) getWord8  instance Binary Status where   put Status{..} = do
Game/LambdaHack/Common/Feature.hs view
@@ -5,14 +5,15 @@   ) where  import Data.Binary+import Data.Hashable (Hashable) import Data.Text (Text) import GHC.Generics (Generic) -import Game.LambdaHack.Common.Effect+import qualified Game.LambdaHack.Common.Effect as Effect  -- | All possible terrain tile features. data Feature =-    Cause !(Effect Int)  -- ^ causes the effect when triggered+    Cause !(Effect.Effect Int)  -- ^ causes the effect when triggered   | OpenTo !Text         -- ^ goes from a closed to an open tile when altered   | CloseTo !Text        -- ^ goes from an open to a closed tile when altered   | ChangeTo !Text       -- ^ alters tile, but does not change walkability@@ -23,12 +24,16 @@   | Clear                -- ^ actors can see through   | Dark                 -- ^ is not lit with an ambient shine   | Suspect              -- ^ may not be what it seems (clients only)-  | Aura !(Effect Int)   -- ^ sustains the effect continuously, TODO+  | Aura !(Effect.Effect Int)  -- ^ sustains the effect continuously, TODO   | Impenetrable         -- ^ can never be excavated nor seen through -  | CanItem              -- ^ items can be generated there-  | CanActor             -- ^ actors and stairs can be generated there+  | OftenItem            -- ^ initial items often generated there+  | OftenActor           -- ^ initial actors and stairs often generated there+  | NoItem               -- ^ no items ever generated there+  | NoActor              -- ^ no actors nor stairs ever generated there   | Trail                -- ^ used for visible trails throughout the level   deriving (Show, Read, Eq, Ord, Generic)  instance Binary Feature++instance Hashable Feature
+ Game/LambdaHack/Common/File.hs view
@@ -0,0 +1,86 @@+-- | Saving/loading with serialization and compression.+module Game.LambdaHack.Common.File+  ( encodeEOF, strictDecodeEOF, tryCreateDir, tryCopyDataFiles, appDataDir+  ) where++import qualified Codec.Compression.Zlib as Z+import qualified Control.Exception as Ex hiding (handle)+import Control.Monad+import Data.Binary+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Char as Char+import System.Directory+import System.Environment+import System.FilePath+import System.IO++-- | Serialize, compress and save data.+-- Note that LBS.writeFile opens the file in binary mode.+encodeData :: Binary a => FilePath -> a -> IO ()+encodeData f a = do+  let tmpPath = f <.> "tmp"+  Ex.bracketOnError+    (openBinaryFile tmpPath WriteMode)+    (\h -> hClose h >> removeFile tmpPath)+    (\h -> do+       LBS.hPut h . Z.compress . encode $ a+       hClose h+       renameFile tmpPath f+    )++-- | Serialize, compress and save data with an EOF marker.+-- The @OK@ is used as an EOF marker to ensure any apparent problems with+-- corrupted files are reported to the user ASAP.+encodeEOF :: Binary a => FilePath -> a -> IO ()+encodeEOF f a = encodeData f (a, "OK" :: String)++-- | Read and decompress the serialized data.+strictReadSerialized :: FilePath -> IO LBS.ByteString+strictReadSerialized f =+  withBinaryFile f ReadMode $ \ h -> do+    c <- LBS.hGetContents h+    let d = Z.decompress c+    LBS.length d `seq` return d++-- | Read, decompress and deserialize data.+strictDecodeData :: Binary a => FilePath -> IO a+strictDecodeData = fmap decode . strictReadSerialized++-- | Read, decompress and deserialize data with an EOF marker.+-- The @OK@ EOF marker ensures any easily detectable file corruption+-- is discovered and reported before the function returns.+strictDecodeEOF :: Binary a => FilePath -> IO a+strictDecodeEOF f = do+  (a, n) <- strictDecodeData f+  if n == ("OK" :: String)+    then return $! a+    else error $ "Fatal error: corrupted file " ++ f++-- | Try to create a directory, if it doesn't exist. Terminate the program+-- with an exception if the directory does not exist, but can't be created.+tryCreateDir :: FilePath -> IO ()+tryCreateDir dir = do+  dirExists <- doesDirectoryExist dir+  unless dirExists $ createDirectory dir++-- | Try to copy over data files, if not already there.+tryCopyDataFiles :: FilePath+                 -> (FilePath -> IO FilePath)+                 -> [(FilePath, FilePath)]+                 -> IO ()+tryCopyDataFiles dataDir pathsDataFile files =+  let cpFile (fin, fout) = do+        pathsDataIn <- pathsDataFile fin+        bIn <- doesFileExist pathsDataIn+        let pathsDataOut = dataDir </> fout+        bOut <- doesFileExist pathsDataOut+        when (not bOut && bIn) $ copyFile pathsDataIn pathsDataOut+  in mapM_ cpFile files++-- | Personal data directory for the game. Depends on the OS and the game,+-- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.+appDataDir :: IO FilePath+appDataDir = do+  progName <- getProgName+  let name = takeWhile Char.isAlphaNum progName+  getAppUserDataDirectory name
Game/LambdaHack/Common/Flavour.hs view
@@ -12,7 +12,7 @@   ) where  import Data.Binary-import qualified Data.Hashable as Hashable+import Data.Hashable (Hashable) import Data.Text (Text) import GHC.Generics (Generic) @@ -26,7 +26,7 @@   }   deriving (Show, Eq, Ord, Generic) -instance Hashable.Hashable Flavour+instance Hashable Flavour  instance Binary Flavour
+ Game/LambdaHack/Common/Frequency.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveFoldable, DeriveGeneric, DeriveTraversable #-}+-- | A list of items with relative frequencies of appearance.+module Game.LambdaHack.Common.Frequency+  ( -- * The @Frequency@ type+    Frequency+    -- * Construction+  , uniformFreq, toFreq+    -- * Transformation+  , scaleFreq, renameFreq, setFreq+    -- * Consumption+  , nullFreq, runFrequency, nameFrequency+  , maxFreq, minFreq, meanFreq+  ) where++import Control.Applicative+import Control.Arrow (first, second)+import Control.Exception.Assert.Sugar+import Control.Monad+import Data.Binary+import Data.Foldable (Foldable)+import Data.Hashable (Hashable)+import Data.Ratio+import Data.Text (Text)+import Data.Traversable (Traversable)+import GHC.Generics (Generic)++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).+--+-- The @Eq@ instance compares raw representations, not relative,+-- normalized frequencies, so operations don't need to preserve+-- the expected equalities, unless they do some kind of normalization+-- (see 'Dice').+data Frequency a = Frequency+  { nameFrequency :: Text         -- ^ short description for debug, etc.;+                                  --   keep it lazy, because it's rarely used+  , runFrequency  :: ![(Int, a)]  -- ^ give acces to raw frequency values+  }+  deriving (Show, Read, Eq, Ord, Foldable, Traversable, Generic)++instance Monad Frequency where+  {-# INLINE return #-}+  return x = Frequency "return" [(1, x)]+  Frequency name xs >>= f =+    Frequency ("bind (" <> name <> ")")+              [ (p * q, y) | (p, x) <- xs+                           , (q, y) <- runFrequency (f x) ]++instance Functor Frequency where+  fmap f (Frequency name xs) = Frequency name (map (second f) xs)++instance Applicative Frequency where+  pure  = return+  Frequency fname fs <*> Frequency yname ys =+    Frequency ("(" <> fname <> ") <*> (" <> yname <> ")")+              [ (p * q, f y) | (p, f) <- fs+                             , (q, y) <- ys ]++instance MonadPlus Frequency where+  mplus (Frequency xname xs) (Frequency yname ys) =+    let name = case (xs, ys) of+          ([], []) -> "[]"+          ([], _ ) -> yname+          (_,  []) -> xname+          _ -> "(" <> xname <> ") ++ (" <> yname <> ")"+    in Frequency name (xs ++ ys)+  mzero = Frequency "[]" []++instance Alternative Frequency where+  (<|>) = mplus+  empty = mzero++instance Hashable a => Hashable (Frequency a)++instance Binary a => Binary (Frequency a)++-- | Uniform discrete frequency distribution.+uniformFreq :: Text -> [a] -> Frequency a+uniformFreq name = Frequency name . map (\x -> (1, x))++-- | Takes a name and a list of frequencies and items+-- into the frequency distribution.+toFreq :: Text -> [(Int, a)] -> Frequency a+toFreq = Frequency++-- | Scale frequecy distribution, multiplying it+-- by a positive integer constant.+scaleFreq :: Show a => Int -> Frequency a -> Frequency a+scaleFreq n (Frequency name xs) =+  assert (n > 0 `blame` "non-positive frequency scale" `twith` (name, n, xs)) $+  Frequency name (map (first (* n)) xs)++-- | Change the description of the frequency.+renameFreq :: Text -> Frequency a -> Frequency a+renameFreq newName fr = fr {nameFrequency = newName}++-- | Set frequency of an element.+setFreq :: Eq a => Frequency a -> a -> Int -> Frequency a+setFreq (Frequency name xs) x n =+  let f (_, y) | y == x = (n, x)+      f my = my+  in Frequency name $ map f xs++-- | Test if the frequency distribution is empty.+nullFreq :: Frequency a -> Bool+nullFreq (Frequency _ fs) = all (<= 0) $ map fst 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++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++meanFreq :: (Show a, Integral a) => Frequency a -> Rational+meanFreq fr@(Frequency _ xs) = case filter ((> 0 ) . fst) 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
Game/LambdaHack/Common/HighScore.hs view
@@ -1,59 +1,86 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} -- | High score table operations. module Game.LambdaHack.Common.HighScore-  ( ScoreTable, empty, register, highSlideshow+  ( ScoreTable, empty, register, showScore, getRecord, highSlideshow   ) where +import Control.Exception.Assert.Sugar import Data.Binary+import qualified Data.EnumMap.Strict as EM+import Data.List+import Data.Maybe import Data.Text (Text) import qualified Data.Text as T+import GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU import System.Time-import Text.Printf  import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ItemKind  -- | A single score record. Records are ordered in the highscore table, -- from the best to the worst, in lexicographic ordering wrt the fields below. data ScoreRecord = ScoreRecord-  { points     :: !Int        -- ^ the score-  , negTime    :: !Time       -- ^ game time spent (negated, so less better)-  , date       :: !ClockTime  -- ^ date of the last game interruption-  , status     :: !Status     -- ^ reason of the game interruption-  , difficulty :: !Int        -- ^ difficulty of the game+  { points       :: !Int        -- ^ the score+  , negTime      :: !Time       -- ^ game time spent (negated, so less better)+  , date         :: !ClockTime  -- ^ date of the last game interruption+  , status       :: !Status     -- ^ reason of the game interruption+  , difficulty   :: !Int        -- ^ difficulty of the game+  , gplayerName  :: !Text       -- ^ name of the faction's gplayer+  , ourVictims   :: !(EM.EnumMap (Kind.Id ItemKind) Int)  -- ^ allies lost+  , theirVictims :: !(EM.EnumMap (Kind.Id ItemKind) Int)  -- ^ foes killed   }-  deriving (Eq, Ord)+  deriving (Eq, Ord, Show, Generic) --- TODO: move all to Text+instance Binary ClockTime where+  put (TOD cs cp) = do+    put cs+    put cp+  get = do+    cs <- get+    cp <- get+    return $! TOD cs cp++instance Binary ScoreRecord+ -- | Show a single high score, from the given ranking in the high score table. showScore :: (Int, ScoreRecord) -> [Text] showScore (pos, score) =   let Status{stOutcome, stDepth} = status score       died = case stOutcome of-        Killed   -> "Perished on level " ++ show (abs stDepth)-        Defeated -> "Was defeated"-        Camping  -> "Camps somewhere"-        Conquer  -> "Slew all opposition"-        Escape   -> "Emerged victorious"-        Restart  -> "Resigned prematurely"-      curDate = calendarTimeToString . toUTCTime . date $ score-      turns = - (negTime score `timeFit` timeTurn)-      diff = 5 - difficulty score-      diffText :: String-      diffText | diff == 5 = ""-               | otherwise = printf " (difficulty %d)" diff-     -- TODO: the spaces at the end are hand-crafted. Remove when display-     -- of overlays adds such spaces automatically.-  in map T.pack-       [ ""-       , printf "%4d. %6d  %s%s"-                pos (points score) died diffText-       , "              " ++ printf "after %d turns on %s." turns curDate-       ]+        Killed   -> "perished on level" <+> tshow (abs stDepth)+        Defeated -> "was defeated"+        Camping  -> "camps somewhere"+        Conquer  -> "slew all opposition"+        Escape   -> "emerged victorious"+        Restart  -> "resigned prematurely"+      curDate = T.pack $ calendarTimeToString . toUTCTime . date $ score+      turns = absoluteTimeNegate (negTime score) `timeFitUp` timeTurn+      tpos = T.justifyRight 3 ' ' $ tshow pos+      tscore = T.justifyRight 6 ' ' $ tshow $ points score+      victims = let nkilled = sum $ EM.elems $ theirVictims score+                    nlost = sum $ EM.elems $ ourVictims score+                in "killed" <+> tshow nkilled <> ", lost" <+> tshow nlost+      diff = difficulty score+      diffText | diff == difficultyDefault = ""+               | otherwise = "difficulty" <+> tshow diff <> ", "+      tturns = makePhrase $ [MU.CarWs turns "turn"]+  in [ tpos <> "." <+> tscore <+> "The" <+> gplayerName score <+> "team"+       <+> died <> "," <+> victims <> ","+     , "            "+       <> diffText <> "after" <+> tturns <+> "on" <+> curDate <> "."+     ] +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)@@ -75,26 +102,47 @@  -- | Register a new score in a score table. register :: ScoreTable  -- ^ old table-         -> Int         -- ^ the total score. not halved yet+         -> Int         -- ^ the total value of faction items          -> Time        -- ^ game time spent          -> Status      -- ^ reason of the game interruption          -> ClockTime   -- ^ current date          -> Int         -- ^ difficulty level-         -> Maybe (ScoreTable, Int)-register table total time status@Status{stOutcome} date difficulty =-  let pUnscaled = if stOutcome `elem` [Killed, Defeated, Restart]-                  then (total + 1) `div` 2-                  else if stOutcome == Conquer-                       then let turnsSpent = timeFit time timeTurn-                                speedup = 10000 - 5 * turnsSpent-                                bonus = sqrt $ fromIntegral speedup :: Double-                            in 10 + floor bonus-                       else total-      points = (round :: Double -> Int)-               $ fromIntegral pUnscaled * 1.5 ^^ difficulty-      negTime = timeNegate time+         -> 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+         -> (Bool, (ScoreTable, Int))+register table total time status@Status{stOutcome} date difficulty gplayerName+         ourVictims theirVictims fightsSpawners =+  let pBase =+        if fightsSpawners+        -- 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 fightsSpawners+        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+      points = (ceiling :: Double -> Int)+               $ pSum * 1.5 ^^ (- (difficultyCoeff difficulty))+      negTime = absoluteTimeNegate time       score = ScoreRecord{..}-  in if points > 0 then Just $ insertPos score table else Nothing+  in (points > 0, insertPos score table)  -- | Show a screenful of the high scores table. -- Parameter height is the number of (3-line) scores to be shown.@@ -102,7 +150,7 @@ tshowable (ScoreTable table) start height =   let zipped    = zip [1..] table       screenful = take height . drop (start - 1) $ zipped-  in concatMap 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]]@@ -115,52 +163,37 @@ -- | Generate a slideshow with the current and previous scores. highSlideshow :: ScoreTable -- ^ current score table               -> Int        -- ^ position of the current score in the table-              -> Status     -- ^ reason of the game interruption               -> Slideshow-highSlideshow table pos status =+highSlideshow table pos =   let (_, nlines) = normalLevelBound  -- TODO: query terminal size instead       height = nlines `div` 3+      posStatus = status $ getRecord pos table       (subject, person, msgUnless) =-        case stOutcome status of-          Killed | stDepth status <= 1 ->-            ("your short-lived struggle", MU.Sg3rd, "(score halved)")+        case stOutcome posStatus of+          Killed | stDepth posStatus <= 1 ->+            ("your short-lived struggle", MU.Sg3rd, "(no bonus)")           Killed ->-            ("your heroic deeds", MU.PlEtc, "(score halved)")+            ("your heroic deeds", MU.PlEtc, "(no bonus)")           Defeated ->-            ("your futile efforts", MU.PlEtc, "(score halved)")+            ("your futile efforts", MU.PlEtc, "(no bonus)")           Camping ->-            ("your valiant exploits", MU.PlEtc, "(unless you are slain)")+            -- TODO: this is only according to the limited player knowledge;+            -- the final score can be different; say this somewhere+            ("your valiant exploits", MU.PlEtc, "")           Conquer ->             ("your ruthless victory", MU.Sg3rd,              if pos <= height              then "among the greatest heroes"-             else "(score based on time)")+             else "(bonus included)")           Escape ->             ("your dashing coup", MU.Sg3rd,              if pos <= height              then "among the greatest heroes"-             else "")+             else "(bonus included)")           Restart ->-            ("your abortive attempt", MU.Sg3rd, "(score halved)")+            ("your abortive attempt", MU.Sg3rd, "(no bonus)")       msg = makeSentence         [ MU.SubjectVerb person MU.Yes subject "award you"         , MU.Ordinal pos, "place"         , msgUnless ]-  in toSlideshow True $ map ([msg] ++) $ showCloseScores pos table height--instance Binary ScoreRecord where-  put (ScoreRecord p n (TOD cs cp) s difficulty) = do-    put p-    put n-    put cs-    put cp-    put s-    put difficulty-  get = do-    p <- get-    n <- get-    cs <- get-    cp <- get-    s <- get-    difficulty <- get-    return $! ScoreRecord p n (TOD cs cp) s difficulty+  in toSlideshow False $ map ([msg, "\n"] ++) $ showCloseScores pos table height
− Game/LambdaHack/Common/HumanCmd.hs 
@@ -1,158 +0,0 @@--- | Abstract syntax human player commands.-module Game.LambdaHack.Common.HumanCmd-  ( CmdCategory(..), HumanCmd(..), Trigger(..)-  , noRemoteHumanCmd, categoryDescription, cmdDescription-  ) where--import Control.Exception.Assert.Sugar-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU--import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Vector--data CmdCategory = CmdMenu | CmdMove | CmdItem | CmdTgt | CmdMeta | CmdDebug-  deriving (Show, Read, Eq)--categoryDescription :: CmdCategory -> Text-categoryDescription CmdMenu = "Main Menu"-categoryDescription CmdMove = "Movement and terrain alteration"-categoryDescription CmdItem = "Inventory and items"-categoryDescription CmdTgt = "Targeting"-categoryDescription CmdMeta = "Assorted"-categoryDescription CmdDebug = "Debug"---- | Abstract syntax of player commands.-data HumanCmd =-    -- These usually take time.-    Move !Vector-  | Run !Vector-  | Wait-  | Pickup-  | Drop-  | Project     ![Trigger]-  | Apply       ![Trigger]-  | AlterDir    ![Trigger]-  | TriggerTile ![Trigger]-  | StepToTarget-  | Resend-    -- Below this line, commands do not take time.-  | GameRestart !Text-  | GameExit-  | GameSave-  | GameDifficultyCycle-    -- Below this line, commands do not notify the server.-  | PickLeader !Int-  | MemberCycle-  | MemberBack-  | Inventory-  | SelectActor-  | SelectNone-  | Clear-  | Repeat !Int-  | Record-  | History-  | MarkVision-  | MarkSmell-  | MarkSuspect-  | Help-  | MainMenu-  | Macro !Text ![String]-    -- These are mostly related to targeting.-  | MoveCursor !Vector !Int-  | TgtFloor-  | TgtEnemy-  | TgtUnknown-  | TgtItem-  | TgtStair !Bool-  | TgtAscend !Int-  | EpsIncr !Bool-  | TgtClear-  | Cancel-  | Accept-  deriving (Eq, Ord, Show, Read)--data Trigger =-    ApplyItem {verb :: !MU.Part, object :: !MU.Part, symbol :: !Char}-  | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature}-  | TriggerFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature}-  deriving (Show, Read, Eq, Ord)---- | Commands that are forbidden on a remote level, because they--- would usually take time when invoked on one.--- Note that some commands that take time are not included,--- because they don't take time in targeting mode.-noRemoteHumanCmd :: HumanCmd -> Bool-noRemoteHumanCmd cmd = case cmd of-  Wait          -> True-  Pickup        -> True-  Drop          -> True-  Project{}     -> True-  Apply{}       -> True-  AlterDir{}    -> True-  StepToTarget  -> True-  Resend        -> True-  _             -> False---- | Description of player commands.-cmdDescription :: HumanCmd -> Text-cmdDescription cmd = case cmd of-  Move v      -> "move" <+> compassText v-  Run v       -> "run" <+> compassText v-  Wait        -> "wait"-  Pickup      -> "get an object"-  Drop        -> "drop an object"-  Project ts  -> triggerDescription ts-  Apply ts    -> triggerDescription ts-  AlterDir ts -> triggerDescription ts-  TriggerTile ts -> triggerDescription ts-  StepToTarget -> "make one step towards the target"-  Resend      -> "resend last server command"--  GameRestart t -> "new" <+> t <+> "game"-  GameExit    -> "save and exit"-  GameSave    -> "save game"--  GameDifficultyCycle -> "cycle difficulty of the next game"-  PickLeader{} -> "pick leader"-  MemberCycle -> "cycle among party members on the level"-  MemberBack  -> "cycle among party members in the dungeon"-  Inventory   -> "display inventory"-  SelectActor -> "select (or deselect) a party member"-  SelectNone  -> "deselect (or select) all on the level"-  Clear       -> "clear messages"-  Repeat 1    -> "play back last keys"-  Repeat n    -> "play back last keys" <+> tshow n <+> "times"-  Record      -> "start recording a macro"-  History     -> "display player diary"-  MarkVision  -> "mark visible area"-  MarkSmell   -> "mark smell"-  MarkSuspect -> "mark suspect terrain"-  Help        -> "display help"-  MainMenu    -> "display the Main Menu"-  Macro t _   -> t--  MoveCursor v 1 -> "move cursor" <+> compassText v-  MoveCursor v k ->-    "move cursor up to" <+> tshow k <+> "steps" <+> compassText v-  TgtFloor    -> "cycle targeting mode"-  TgtEnemy    -> "target enemy"-  TgtUnknown  -> "target the closest unknown spot"-  TgtItem     -> "target the closest item"-  TgtStair up -> "target the closest stairs" <+> if up then "up" else "down"-  TgtAscend k | k == 1  -> "target next shallower level"-  TgtAscend k | k >= 2  -> "target" <+> tshow k    <+> "levels shallower"-  TgtAscend k | k == -1 -> "target next deeper level"-  TgtAscend k | k <= -2 -> "target" <+> tshow (-k) <+> "levels deeper"-  TgtAscend _ -> assert `failure` "void level change when targeting"-                        `twith` cmd-  EpsIncr True  -> "swerve targeting line"-  EpsIncr False -> "unswerve targeting line"-  TgtClear    -> "clear target/cursor"-  Cancel      -> "cancel action"-  Accept      -> "accept choice"--triggerDescription :: [Trigger] -> Text-triggerDescription [] = "trigger a thing"-triggerDescription (t : _) = makePhrase [verb t, object t]
Game/LambdaHack/Common/Item.hs view
@@ -1,46 +1,31 @@ {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | Weapons, treasure and all the other items in the game.--- No operation in this module--- involves the 'State' or 'Action' type.--- TODO: Document after it's rethought and rewritten wrt separating--- inventory manangement and items proper.+-- No operation in this module involves the state or any of our custom monads. module Game.LambdaHack.Common.Item-  ( -- * Teh @Item@ type-    ItemId, Item(..), jkind, buildItem, newItem-    -- * Inventory search-  , strongestSearch, strongestSword, strongestRegen-   -- * The item discovery types-  , ItemKindIx, Discovery, DiscoRev, serverDiscos-    -- * The @FlavourMap@ type-  , FlavourMap, emptyFlavourMap, dungeonFlavourMap-    -- * Textual description-  , partItem, partItemWs, partItemAW-    -- * Assorted-  , isFragile, isExplosive, isLingering, causeIEffects+  ( -- * The @Item@ type+    ItemId, Item(..), seedToAspectsEffects+    -- * Item discovery types+  , ItemKindIx, Discovery, ItemSeed, ItemAspectEffect(..), DiscoAE+  , ItemFull(..), ItemDisco(..), itemNoDisco, itemNoAE+    -- * Inventory management types+  , ItemBag, ItemDict, ItemKnown   ) where -import Control.Exception.Assert.Sugar-import Control.Monad+import qualified Control.Monad.State as St import Data.Binary import qualified Data.EnumMap.Strict as EM-import qualified Data.Hashable as Hashable+import Data.Hashable (Hashable) import qualified Data.Ix as Ix-import Data.List-import Data.Maybe-import qualified Data.Set as S import Data.Text (Text) import GHC.Generics (Generic)-import qualified NLP.Miniutter.English as MU+import System.Random (mkStdGen)  import Game.LambdaHack.Common.Effect import Game.LambdaHack.Common.Flavour-import qualified Game.LambdaHack.Common.ItemFeature as IF import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Random import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Utils.Frequency  -- | A unique identifier of an item in the dungeon. newtype ItemId = ItemId Int@@ -49,209 +34,90 @@ -- | An index of the kind id of an item. Clients have partial knowledge -- how these idexes map to kind ids. They gain knowledge by identifying items. newtype ItemKindIx = ItemKindIx Int-  deriving (Show, Eq, Ord, Enum, Ix.Ix, Hashable.Hashable, Binary)+  deriving (Show, Eq, Ord, Enum, Ix.Ix, Hashable, Binary)  -- | The map of item kind indexes to item kind ids. -- The full map, as known by the server, is a bijection. type Discovery = EM.EnumMap ItemKindIx (Kind.Id ItemKind) --- | The reverse map to @Discovery@, needed for item creation.-type DiscoRev = EM.EnumMap (Kind.Id ItemKind) ItemKindIx+-- | A seed for rolling aspects and effects of an item+-- Clients have partial knowledge of how item ids map to the seeds.+-- They gain knowledge by identifying items.+newtype ItemSeed = ItemSeed Int+  deriving (Show, Eq, Ord, Enum, Hashable, Binary) --- TODO: somehow hide from clients jeffect of unidentified items.--- | Game items in inventories or strewn around the dungeon.--- The fields @jsymbol@, @jname@ and @jflavour@ make it possible to refer to--- and draw an unidentified item. Full information about item is available--- through the @jkindIx@ index as soon as the item is identified.-data Item = Item-  { jkindIx  :: !ItemKindIx  -- ^ index pointing to the kind of the item-  , jsymbol  :: !Char        -- ^ individual map symbol-  , jname    :: !Text        -- ^ individual generic name-  , jflavour :: !Flavour     -- ^ individual flavour-  , jeffect  :: !(Effect Int)  -- ^ the effect when activated-  , jweight  :: !Int         -- ^ weight in grams, obvious enough+data ItemAspectEffect = ItemAspectEffect+  { jaspects :: ![Aspect Int]  -- ^ the aspects of the item+  , jeffects :: ![Effect Int]  -- ^ the effects when activated   }-  deriving (Show, Eq, Ord, Generic)--instance Hashable.Hashable Item--instance Binary Item---- | Recover a kind id of an item, if identified.-jkind :: Discovery -> Item -> Maybe (Kind.Id ItemKind)-jkind disco i = EM.lookup (jkindIx i) disco--serverDiscos :: Kind.Ops ItemKind -> Rnd (Discovery, DiscoRev)-serverDiscos Kind.Ops{obounds, ofoldrWithKey} = do-  let ixs = map ItemKindIx $ take (Ix.rangeSize obounds) [0..]-      shuffle :: Eq a => [a] -> Rnd [a]-      shuffle [] = return []-      shuffle l = do-        x <- oneOf l-        fmap (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)-      f ik  _ (ikMap, _, []) =-        assert `failure` "too short ixs" `twith` (ik, ikMap)-      (discoS, discoRev, _) =-        ofoldrWithKey f (EM.empty, EM.empty, shuffled)-  return (discoS, discoRev)---- | Build an item with the given stats.-buildItem :: FlavourMap -> DiscoRev-          -> Kind.Id ItemKind -> ItemKind -> Effect Int -> Item-buildItem (FlavourMap flavour) discoRev ikChosen kind jeffect =-  let jkindIx  = discoRev EM.! ikChosen-      jsymbol  = isymbol kind-      jname    = iname kind-      jflavour =-        case iflavour kind of-          [fl] -> fl-          _ -> flavour EM.! ikChosen-      jweight = iweight kind-  in Item{..}---- | Generate an item based on level.-newItem :: Kind.Ops ItemKind -> FlavourMap -> DiscoRev-        -> Frequency Text -> Int -> Int-        -> Rnd (Item, Int, ItemKind)-newItem coitem@Kind.Ops{opick, okind} flavour discoRev itemFreq lvl depth = do-  itemGroup <- frequency itemFreq-  let castItem :: Int -> Rnd (Item, Int, ItemKind)-      castItem 0 | nullFreq itemFreq = assert `failure` "no fallback items"-                                              `twith` (itemFreq, lvl, depth)-      castItem 0 = do-        let newFreq = setFreq itemFreq itemGroup 0-        newItem coitem flavour discoRev newFreq lvl depth-      castItem count = do-        ikChosen <- fmap (fromMaybe $ assert `failure` itemGroup)-                    $ opick itemGroup (const True)-        let kind = okind ikChosen-        jcount <- castDeep lvl depth (icount kind)-        if jcount == 0 then-          castItem $ count - 1-        else do-          let kindEffect = case causeIEffects coitem ikChosen of-                [] -> NoEffect-                eff : _TODO -> eff-          effect <- effectTrav kindEffect (castDeep lvl depth)-          return ( buildItem flavour discoRev ikChosen kind effect-                 , jcount-                 , kind )-  castItem 10---- | Flavours assigned by the server to item kinds, in this particular game.-newtype FlavourMap = FlavourMap (EM.EnumMap (Kind.Id ItemKind) Flavour)-  deriving (Show, Binary)+  deriving (Show, Eq, Generic) -emptyFlavourMap :: FlavourMap-emptyFlavourMap = FlavourMap EM.empty+instance Binary ItemAspectEffect --- | Assigns flavours to item kinds. Assures no flavor is repeated,--- except for items with only one permitted flavour.-rollFlavourMap :: Kind.Id ItemKind -> ItemKind-               -> Rnd (EM.EnumMap (Kind.Id ItemKind) Flavour, S.Set Flavour)-               -> Rnd (EM.EnumMap (Kind.Id ItemKind) Flavour, S.Set Flavour)-rollFlavourMap key ik rnd =-  let flavours = iflavour ik-  in if length flavours == 1-     then rnd-     else do-       (assocs, available) <- rnd-       let proper = S.fromList flavours `S.intersection` available-       flavour <- oneOf (S.toList proper)-       return (EM.insert key flavour assocs, S.delete flavour available)+instance Hashable ItemAspectEffect --- | Randomly chooses flavour for all item kinds for this game.-dungeonFlavourMap :: Kind.Ops ItemKind -> Rnd FlavourMap-dungeonFlavourMap Kind.Ops{ofoldrWithKey} =-  liftM (FlavourMap . fst) $-    ofoldrWithKey rollFlavourMap (return (EM.empty, S.fromList stdFlav))+-- | The map of item ids to item aspects and effects.+-- The full map is known by the server.+type DiscoAE = EM.EnumMap ItemId ItemAspectEffect -strongestItem :: [(ItemId, Item)] -> (Item -> Maybe Int)-              -> Maybe (Int, (ItemId, Item))-strongestItem is p =-  let ks = map (p . snd) is-  in case zip ks is of-    [] -> Nothing-    kis -> case maximum kis of-      (Nothing, _) -> Nothing-      (Just k, iki) -> Just (k, iki)+data ItemDisco = ItemDisco+  { itemKindId :: Kind.Id ItemKind+  , itemKind   :: ItemKind+  , itemAE     :: Maybe ItemAspectEffect+  }+  deriving Show -strongestSearch :: [(ItemId, Item)] -> Maybe (Int, (ItemId, Item))-strongestSearch is =-  strongestItem is $ \ i ->-    case jeffect i of Searching k -> Just k; _ -> Nothing+data ItemFull = ItemFull+  { itemBase  :: !Item+  , itemK     :: !Int+  , itemDisco :: !(Maybe ItemDisco)+  }+  deriving Show -strongestSword :: Kind.COps -> [(ItemId, Item)] -> Maybe (Int, (ItemId, Item))-strongestSword Kind.COps{corule} is =-  strongestItem is $ \ i ->-    case jeffect i of-      Hurt d k | jsymbol i `elem` ritemMelee (Kind.stdRuleset corule)-        -> Just $ floor (meanDice d) + k-      _ -> Nothing+itemNoDisco :: (Item, Int) -> ItemFull+itemNoDisco (itemBase, itemK) =+  ItemFull {itemBase, itemK, itemDisco=Nothing} -strongestRegen :: [(ItemId, Item)] -> Maybe (Int, (ItemId, Item))-strongestRegen is =-  strongestItem is $ \ i ->-    case jeffect i of Regeneration k -> Just k; _ -> Nothing+itemNoAE :: ItemFull -> ItemFull+itemNoAE itemFull@ItemFull{..} =+  let f idisco = idisco {itemAE = Nothing}+      newDisco = fmap f itemDisco+  in itemFull {itemDisco = newDisco} -isFragile :: Kind.Ops ItemKind -> Discovery -> Item -> Bool-isFragile Kind.Ops{okind} disco i =-  case jkind disco i of-    Nothing -> False-    Just ik ->-      let getTo IF.Fragile _acc = True-          getTo IF.Explode{} _acc = True-          getTo _ acc = acc-      in foldr getTo False $ ifeature $ okind ik+-- | Game items in actor possesion or strewn around the dungeon.+-- The fields @jsymbol@, @jname@ and @jflavour@ make it possible to refer to+-- and draw an unidentified item. Full information about item is available+-- through the @jkindIx@ index as soon as the item is identified.+data Item = Item+  { jkindIx  :: !ItemKindIx    -- ^ index pointing to the kind of the item+  , jlid     :: !LevelId       -- ^ the level on which item was created+  , jsymbol  :: !Char          -- ^ individual map symbol+  , jname    :: !Text          -- ^ individual generic name+  , jflavour :: !Flavour       -- ^ individual flavour+  , jfeature :: ![Feature]     -- ^ public properties+  , jweight  :: !Int           -- ^ weight in grams, obvious enough+  }+  deriving (Show, Eq, Generic) -isExplosive :: Kind.Ops ItemKind -> Discovery -> Item -> Maybe Text-isExplosive Kind.Ops{okind} disco i =-  case jkind disco i of-    Nothing -> Nothing-    Just ik ->-      let getTo (IF.Explode cgroup) _acc = Just cgroup-          getTo _ acc = acc-      in foldr getTo Nothing $ ifeature $ okind ik+instance Hashable Item -isLingering :: Kind.Ops ItemKind -> Discovery -> Item -> Int-isLingering Kind.Ops{okind} disco i =-  case jkind disco i of-    Nothing -> 100-    Just ik ->-      let getTo (IF.Linger percent) _acc = percent-          getTo _ acc = acc-      in foldr getTo 100 $ ifeature $ okind ik+instance Binary Item -causeIEffects :: Kind.Ops ItemKind -> Kind.Id ItemKind -> [Effect RollDeep]-causeIEffects Kind.Ops{okind} ik = do-  let getTo (IF.Cause eff) acc = eff : acc-      getTo _ acc = acc-  foldr getTo [] $ ifeature $ okind ik+seedToAspectsEffects :: ItemSeed -> ItemKind -> AbsDepth -> AbsDepth+                     -> ItemAspectEffect+seedToAspectsEffects (ItemSeed itemSeed) kind ldepth totalDepth =+  let castD = castDice ldepth totalDepth+      rollAE = do+        aspects <- mapM (flip aspectTrav castD) (iaspects kind)+        effects <- mapM (flip effectTrav castD) (ieffects kind)+        return (aspects, effects)+      (jaspects, jeffects) = St.evalState rollAE (mkStdGen itemSeed)+  in ItemAspectEffect{..} --- | The part of speech describing the item.-partItem :: Kind.Ops ItemKind -> Discovery -> Item -> (MU.Part, MU.Part)-partItem _cops disco i =-  let genericName = jname i-      flav = flavourToName $ jflavour i-  in case jkind disco i of-    Nothing ->-      -- TODO: really hide jeffect from a client that has not discovered-      -- that individual item's properties (nor item kind, if there's only-      -- one effect possible for the kind (plus effect deduction))-      (MU.Text $ flav <+> genericName, "")-    Just _ ->-      let eff = effectToSuffix $ jeffect i-      in (MU.Text genericName, MU.Text eff)+type ItemBag = EM.EnumMap ItemId Int -partItemWs :: Kind.Ops ItemKind -> Discovery -> Int -> Item -> MU.Part-partItemWs coitem disco jcount i =-  let (name, stats) = partItem coitem disco i-  in MU.Phrase [MU.CarWs jcount name, stats]+-- | All items in the dungeon (including in actor inventories),+-- indexed by item identifier.+type ItemDict = EM.EnumMap ItemId Item -partItemAW :: Kind.Ops ItemKind -> Discovery -> Item -> MU.Part-partItemAW coitem disco i =-  let (name, stats) = partItem coitem disco i-  in MU.AW $ MU.Phrase [name, stats]+type ItemKnown = (Item, ItemAspectEffect)
+ Game/LambdaHack/Common/ItemDescription.hs view
@@ -0,0 +1,118 @@+-- | Descripitons of items.+module Game.LambdaHack.Common.ItemDescription+  ( partItemN, partItem, partItemWs, partItemAW, partItemWownW+  , itemDesc, textAllAE, viewItem+  ) where++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 Game.LambdaHack.Common.Color as Color+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.EffectDescription+import Game.LambdaHack.Common.Flavour+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Content.ItemKind++-- | The part of speech describing the item parameterized by the number+-- of effects/aspects to show..+partItemN :: Bool -> Int -> CStore -> ItemFull -> (MU.Part, MU.Part)+partItemN fullInfo n cstore 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 cstore itemFull+          ts = take n effTs ++ if length effTs > n then ["(...)"] else []+      in (MU.Text genericName, MU.Phrase $ map MU.Text ts)++-- | The part of speech describing the item.+partItem :: CStore -> ItemFull -> (MU.Part, MU.Part)+partItem = partItemN False 4++textAllAE :: Bool -> CStore -> ItemFull -> [Text]+textAllAE fullInfo cstore ItemFull{itemBase, itemDisco} =+  let features | fullInfo = map featureToSuff $ sort $ jfeature itemBase+               | otherwise = []+  in case itemDisco of+    Nothing -> features+    Just ItemDisco{itemKind, itemAE} ->+      let periodicAspect :: Effect.Aspect a -> Bool+          periodicAspect (Effect.Periodic _) = True+          periodicAspect _ = False+          hurtEffect :: Effect.Effect a -> Bool+          hurtEffect (Effect.Hurt _) = True+          hurtEffect _ = False+          active = cstore `elem` [CEqp, COrgan]+                   || cstore == CGround && isJust (strengthEqpSlot itemBase)+          splitAE :: Ord a+                  => [Effect.Aspect a] -> (Effect.Aspect a -> Text)+                  -> [Effect.Effect a] -> (Effect.Effect a -> Text) -> [Text]+          splitAE aspects ppA effects ppE =+            let (periodicAs, restAs) = partition periodicAspect $ sort aspects+                (hurtEs, restEs) = partition hurtEffect $ sort effects+            in map ppA periodicAs ++ map ppE hurtEs+               ++ if active+                  then map ppA restAs ++ map ppE restEs+                  else map ppE restEs ++ map ppA restAs+          aets = case itemAE of+            Just ItemAspectEffect{jaspects, jeffects} ->+              splitAE jaspects aspectToSuffix+                      jeffects effectToSuffix+            Nothing ->+              splitAE (iaspects itemKind) kindAspectToSuffix+                      (ieffects itemKind) kindEffectToSuffix+      in aets ++ features++partItemWs :: Int -> CStore -> ItemFull -> MU.Part+partItemWs count cstore itemFull =+  let (name, stats) = partItem cstore itemFull+  in MU.Phrase [MU.CarWs count name, stats]++partItemAW :: CStore -> ItemFull -> MU.Part+partItemAW cstore itemFull =+  let (name, stats) = partItem cstore itemFull+  in MU.AW $ MU.Phrase [name, stats]++partItemWownW :: MU.Part -> CStore -> ItemFull -> MU.Part+partItemWownW partA cstore itemFull =+  let (name, stats) = partItem cstore itemFull+  in MU.WownW partA $ MU.Phrase [name, stats]++itemDesc :: CStore -> ItemFull -> Overlay+itemDesc cstore itemFull =+  let (name, stats) = partItemN True 99 cstore itemFull+      nstats = makePhrase [name, stats MU.:> ":"]+      desc = case itemDisco itemFull of+        Nothing -> "This item is as unremarkable as can be."+        Just ItemDisco{itemKind} -> idesc itemKind+      weight = jweight (itemBase itemFull)+      (scaledWeight, unitWeight) =+        if weight > 1000+        then (tshow $ fromIntegral weight / (1000 :: Double), "kg")+        else (tshow weight, "g")+      ln = abs $ fromEnum $ jlid (itemBase itemFull)+      colorSymbol = uncurry (flip Color.AttrChar) (viewItem $ itemBase itemFull)+      f c = Color.AttrChar Color.defAttr c+      lxsize = fst normalLevelBound + 1  -- TODO+      blurb =+        "D"  -- dummy+        <+> nstats+        <+> desc+        <+> makeSentence ["Weighs", MU.Text scaledWeight <> unitWeight]+        <+> makeSentence ["Found on level", MU.Text $ tshow ln]+      splitBlurb = splitText lxsize blurb+      attrBlurb = map (map f . T.unpack) splitBlurb+  in encodeOverlay $ (colorSymbol : tail (head attrBlurb)) : tail attrBlurb++viewItem :: Item -> (Char, Color.Attr)+viewItem item = ( jsymbol item+                , Color.defAttr {Color.fg = flavourToColor $ jflavour item} )
− Game/LambdaHack/Common/ItemFeature.hs 
@@ -1,23 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | Item features.-module Game.LambdaHack.Common.ItemFeature-  ( Feature(..)-  ) where--import Data.Binary-import Data.Text (Text)-import GHC.Generics (Generic)--import Game.LambdaHack.Common.Effect-import Game.LambdaHack.Common.Random---- | All possible item features.-data Feature =-    Cause !(Effect RollDeep)  -- ^ causes the effect when triggered-  | ChangeTo !Text            -- ^ changes to this item kind group when altered-  | Explode !Text             -- ^ explode, producing this group of shrapnel-  | Fragile                   -- ^ breaks even when not hitting an enemy-  | Linger !Int               -- ^ fly for this percentage of 2 turns-  deriving (Show, Eq, Ord, Generic)--instance Binary Feature
+ Game/LambdaHack/Common/ItemStrongest.hs view
@@ -0,0 +1,276 @@+-- | Determining the strongest item wrt some property.+-- No operation in this module involves the state or any of our custom monads.+module Game.LambdaHack.Common.ItemStrongest+  ( -- * Strongest items+    strengthOnSmash, strengthToThrow, strengthEqpSlot, strengthFromEqpSlot+  , strongestSlotNoFilter, strongestSlot, sumSlotNoFilter, sumSkills+    -- * Assorted+  , totalRange, computeTrajectory, itemTrajectory+  , unknownPrecious, permittedRanged, unknownMelee+  ) where++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+import qualified Data.Ord as Ord+import Data.Text (Text)++import qualified Game.LambdaHack.Common.Ability as Ability+import qualified Game.LambdaHack.Common.Dice as Dice+import Game.LambdaHack.Common.Effect+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ItemKind++dice999 :: Dice.Dice -> Int+dice999 d = fromMaybe 999 $ Dice.reduceDice d++strengthAspect :: (Aspect Int -> [b]) -> ItemFull -> [b]+strengthAspect f itemFull =+  case itemDisco itemFull of+    Just ItemDisco{itemAE=Just ItemAspectEffect{jaspects}} ->+      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+    Nothing -> []++strengthAspectMaybe :: Show b => (Aspect Int -> [b]) -> ItemFull -> Maybe b+strengthAspectMaybe f itemFull =+  case strengthAspect f itemFull of+    [] -> Nothing+    [x] -> Just x+    xs -> assert `failure` (xs, itemFull)++strengthEffect999 :: (Effect Int -> [b]) -> ItemFull -> [b]+strengthEffect999 f itemFull =+  case itemDisco itemFull of+    Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->+      concatMap f jeffects+    Just ItemDisco{itemKind=ItemKind{ieffects}} ->+      -- Default for unknown power is 999 to encourage experimenting.+      let trav x = St.evalState (effectTrav x (return . dice999)) ()+      in concatMap f $ map trav ieffects+    Nothing -> []++strengthFeature :: (Feature -> [b]) -> Item -> [b]+strengthFeature f item = concatMap f (jfeature item)++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 _ = []+      hasNoEffects = case itemDisco itemFull of+        Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->+          null jeffects+        Just ItemDisco{itemKind=ItemKind{ieffects}} ->+          null ieffects+        Nothing -> True+  in if hasNoEffects+     then Nothing+     else Just $ sum (strengthEffect999 p itemFull)+                 + if durable then 100 else 0++-- Called only by the server, so 999 is OK.+strengthOnSmash :: ItemFull -> [Effect Int]+strengthOnSmash =+  let p (OnSmash eff) = [eff]+      p _ = []+  in strengthEffect999 p++strengthPeriodic :: ItemFull -> Maybe Int+strengthPeriodic =+  let p (Periodic k) = [k]+      p _ = []+  in strengthAspectMaybe p++strengthAddMaxHP :: ItemFull -> Maybe Int+strengthAddMaxHP =+  let p (AddMaxHP k) = [k]+      p _ = []+  in strengthAspectMaybe p++strengthAddMaxCalm :: ItemFull -> Maybe Int+strengthAddMaxCalm =+  let p (AddMaxCalm k) = [k]+      p _ = []+  in strengthAspectMaybe p++strengthAddSpeed :: ItemFull -> Maybe Int+strengthAddSpeed =+  let p (AddSpeed k) = [k]+      p _ = []+  in strengthAspectMaybe p++strengthAddSkills :: ItemFull -> Maybe Ability.Skills+strengthAddSkills =+  let p (AddSkills a) = [a]+      p _ = []+  in strengthAspectMaybe p++strengthAddHurtMelee :: ItemFull -> Maybe Int+strengthAddHurtMelee =+  let p (AddHurtMelee k) = [k]+      p _ = []+  in strengthAspectMaybe p++strengthAddHurtRanged :: ItemFull -> Maybe Int+strengthAddHurtRanged =+  let p (AddHurtRanged k) = [k]+      p _ = []+  in strengthAspectMaybe p++strengthAddArmorMelee :: ItemFull -> Maybe Int+strengthAddArmorMelee =+  let p (AddArmorMelee k) = [k]+      p _ = []+  in strengthAspectMaybe p++strengthAddArmorRanged :: ItemFull -> Maybe Int+strengthAddArmorRanged =+  let p (AddArmorRanged k) = [k]+      p _ = []+  in strengthAspectMaybe p++strengthAddSight :: ItemFull -> Maybe Int+strengthAddSight =+  let p (AddSight k) = [k]+      p _ = []+  in strengthAspectMaybe p++strengthAddSmell :: ItemFull -> Maybe Int+strengthAddSmell =+  let p (AddSmell k) = [k]+      p _ = []+  in strengthAspectMaybe p++strengthAddLight :: ItemFull -> Maybe Int+strengthAddLight =+  let p (AddLight k) = [k]+      p _ = []+  in strengthAspectMaybe p++strengthEqpSlot :: Item -> Maybe (EqpSlot, Text)+strengthEqpSlot item =+  let p (EqpSlot eqpSlot t) = [(eqpSlot, t)]+      p _ = []+  in case strengthFeature p item of+    [] -> Nothing+    [x] -> Just x+    xs -> assert `failure` (xs, item)++strengthToThrow :: Item -> ThrowMod+strengthToThrow item =+  let p (ToThrow tmod) = [tmod]+      p _ = []+  in case strengthFeature p item of+    [] -> ThrowMod 100 100+    [x] -> x+    xs -> assert `failure` (xs, item)++computeTrajectory :: Int -> Int -> Int -> [Point] -> ([Vector], (Speed, Int))+computeTrajectory weight throwVelocity throwLinger path =+  let speed = speedFromWeight weight throwVelocity+      trange = rangeFromSpeedAndLinger speed throwLinger+      btrajectory = take trange $ pathToTrajectory path+  in (btrajectory, (speed, trange))++itemTrajectory :: Item -> [Point] -> ([Vector], (Speed, Int))+itemTrajectory item path =+  let ThrowMod{..} = strengthToThrow item+  in computeTrajectory (jweight item) throwVelocity throwLinger path++totalRange :: Item -> Int+totalRange item = snd $ snd $ itemTrajectory item []++-- TODO: when all below are aspects, define with+-- (EqpSlotAddMaxHP, AddMaxHP k) -> [k]+strengthFromEqpSlot :: EqpSlot -> ItemFull -> Maybe Int+strengthFromEqpSlot eqpSlot =+  case eqpSlot of+    EqpSlotPeriodic -> strengthPeriodic  -- a very crude approximation+    EqpSlotAddMaxHP -> strengthAddMaxHP+    EqpSlotAddMaxCalm -> strengthAddMaxCalm+    EqpSlotAddSpeed -> strengthAddSpeed+    EqpSlotAddSkills -> \itemFull -> sum . EM.elems <$> strengthAddSkills itemFull+    EqpSlotAddHurtMelee -> strengthAddHurtMelee+    EqpSlotAddHurtRanged -> strengthAddHurtRanged+    EqpSlotAddArmorMelee -> strengthAddArmorMelee+    EqpSlotAddArmorRanged -> strengthAddArmorRanged+    EqpSlotAddSight -> strengthAddSight+    EqpSlotAddSmell -> strengthAddSmell+    EqpSlotAddLight -> strengthAddLight+    EqpSlotWeapon -> strengthMelee++strongestSlotNoFilter :: EqpSlot -> [(ItemId, ItemFull)]+                      -> [(Int, (ItemId, ItemFull))]+strongestSlotNoFilter eqpSlot is =+  let f = strengthFromEqpSlot eqpSlot+      g (iid, itemFull) = (\v -> (v, (iid, itemFull))) <$> (f itemFull)+  in sortBy (flip $ Ord.comparing fst) $ mapMaybe g is++strongestSlot :: EqpSlot -> [(ItemId, ItemFull)]+              -> [(Int, (ItemId, ItemFull))]+strongestSlot eqpSlot is =+  let f (_, itemFull) = case strengthEqpSlot $ itemBase itemFull of+        Just (eqpSlot2, _) | eqpSlot2 == eqpSlot -> True+        _ -> False+      slotIs = filter f is+  in strongestSlotNoFilter eqpSlot slotIs++sumSlotNoFilter :: EqpSlot -> [ItemFull] -> Int+sumSlotNoFilter eqpSlot is = assert (eqpSlot /= EqpSlotWeapon) $  -- no 999+  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))+                   <$> strengthAddSkills itemFull+  in foldr Ability.addSkills Ability.zeroSkills $ mapMaybe g is++unknownPrecious :: ItemFull -> Bool+unknownPrecious itemFull =+  Durable `notElem` jfeature (itemBase itemFull)  -- if durable, no risk+  && case itemDisco itemFull of+    Just ItemDisco{itemAE=Just _} -> False+    _ -> Precious `elem` jfeature (itemBase itemFull)++permittedRanged :: ItemFull -> Maybe Int -> Bool+permittedRanged itemFull _ =+  let hasEffects = case itemDisco itemFull of+        Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects=[]}} -> False+        Just ItemDisco{itemAE=Nothing, itemKind=ItemKind{ieffects=[]}} -> False+        _ -> True+  in hasEffects+     && not (unknownPrecious itemFull)+     && case strengthEqpSlot (itemBase itemFull) of+          Just (EqpSlotAddLight, _) -> True+          Just _ -> False+          Nothing -> True++unknownAspect :: (Aspect Dice.Dice -> [Dice.Dice]) -> ItemFull -> Bool+unknownAspect f itemFull =+  case itemDisco itemFull of+    Just ItemDisco{itemAE=Nothing, itemKind=ItemKind{iaspects}} ->+      let unknown x = Dice.minDice x /= Dice.maxDice x+      in or $ concatMap (map unknown . f) iaspects+    _ -> False++unknownMelee :: [ItemFull] -> Bool+unknownMelee =+  let p (AddHurtMelee k) = [k]+      p _ = []+      f itemFull b = b || unknownAspect p itemFull+  in foldr f False
− Game/LambdaHack/Common/Key.hs 
@@ -1,197 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | Frontend-independent keyboard input operations.-module Game.LambdaHack.Common.Key-  ( Key(..), handleDir, dirAllMoveKey-  , moveBinding, mkKM, keyTranslate, Modifier(..), KM(..), showKM, escKey-  ) where--import Control.Exception.Assert.Sugar-import Data.Binary-import qualified Data.Char as Char-import Data.Text (Text)-import qualified Data.Text as T-import GHC.Generics (Generic)-import Prelude hiding (Left, Right)--import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Vector---- TODO: if the file grows much larger, split it and move a part to Utils/---- | Frontend-independent datatype to represent keys.-data Key =-    Esc-  | Return-  | Space-  | Tab-  | BackTab-  | BackSpace-  | PgUp-  | PgDn-  | Left-  | Right-  | Up-  | Down-  | End-  | Begin-  | Home-  | KP !Char      -- ^ a keypad key for a character (digits and operators)-  | Char !Char    -- ^ a single printable character-  | Unknown !Text -- ^ an unknown key, registered to warn the user-  deriving (Read, Ord, Eq, Generic)--instance Binary Key---- | Our own encoding of modifiers. Incomplete.-data Modifier =-    NoModifier-  | Control-  deriving (Read, Ord, Eq, Generic)--instance Binary Modifier--data KM = KM {modifier :: !Modifier, key :: !Key}-  deriving (Read, Ord, Eq, Generic)--instance Show KM where-  show = T.unpack . showKM--instance Binary KM---- Common and terse names for keys.-showKey :: Key -> Text-showKey (Char c) = T.singleton c-showKey Esc      = "ESC"-showKey Return   = "RET"-showKey Space    = "SPACE"-showKey Tab      = "TAB"-showKey BackTab  = "SHIFT-TAB"-showKey BackSpace = "BACKSPACE"-showKey Up       = "UP"-showKey Down     = "DOWN"-showKey Left     = "LEFT"-showKey Right    = "RIGHT"-showKey Home     = "HOME"-showKey End      = "END"-showKey PgUp     = "PGUP"-showKey PgDn     = "PGDOWN"-showKey Begin    = "BEGIN"-showKey (KP c)   = "KEYPAD(" <> T.singleton c <> ")"-showKey (Unknown s) = s---- | Show a key with a modifier, if any.-showKM :: KM -> Text-showKM KM{modifier=Control, key} = "CTRL-" <> showKey key-showKM KM{modifier=NoModifier, key} = showKey key--escKey :: KM-escKey = KM {modifier = NoModifier, key = Esc}--dirViChar :: [Char]-dirViChar = ['y', 'k', 'u', 'l', 'n', 'j', 'b', 'h']--dirViMoveKey :: [Key]-dirViMoveKey = map Char dirViChar--dirMoveKey :: [Key]-dirMoveKey = [Home, Up, PgUp, Right, PgDn, Down, End, Left]--dirAllMoveKey :: [Key]-dirAllMoveKey = dirViMoveKey ++ dirMoveKey--dirViRunKey :: [Key]-dirViRunKey = map (Char . Char.toUpper) dirViChar--dirRunKey :: [Key]-dirRunKey = map KP dirNums--_dirAllRunKey :: [Key]-_dirAllRunKey = dirViRunKey ++ dirRunKey--dirNums :: [Char]-dirNums = ['7', '8', '9', '6', '3', '2', '1', '4']--dirHeroKey :: [Key]-dirHeroKey = map Char dirNums---- | Configurable event handler for the direction keys.--- Used for directed commands such as close door.-handleDir :: KM -> (Vector -> a) -> a -> a-handleDir KM{modifier=NoModifier, key} h k =-  let assocs = zip dirAllMoveKey $ moves ++ moves-  in maybe k h (lookup key assocs)-handleDir _ _ k = k---- TODO: deduplicate--- | Binding of both sets of movement keys.-moveBinding :: (Vector -> a) -> (Vector -> a)-            -> [(KM, a)]-moveBinding move run =-  let assign f (km, dir) = (km, f dir)-      rNoModifier = repeat NoModifier-      rControl = repeat Control-  in map (assign move) (zip (zipWith KM rNoModifier dirViMoveKey) moves) ++-     map (assign move) (zip (zipWith KM rNoModifier dirMoveKey) moves) ++-     map (assign run)  (zip (zipWith KM rNoModifier dirViRunKey) moves) ++-     map (assign run)  (zip (zipWith KM rNoModifier dirRunKey) moves) ++-     map (assign run)  (zip (zipWith KM rControl dirMoveKey) moves) ++-     map (assign run)  (zip (zipWith KM rControl dirRunKey) moves) ++-     map (assign run)  (zip (zipWith KM rControl dirHeroKey ) moves)--mkKM :: String -> KM-mkKM s = let mkKey sk =-               case keyTranslate sk of-                 Unknown _ ->-                   assert `failure` "unknown key" `twith` s-                 key -> key-         in case s of-           ('C':'T':'R':'L':'-':rest) -> KM {key=mkKey rest, modifier=Control}-           _ -> KM {key=mkKey s, modifier=NoModifier}---- | Translate key from a GTK string description to our internal key type.--- To be used, in particular, for the command bindings and macros--- in the config file.-keyTranslate :: String -> Key-keyTranslate "less"          = Char '<'-keyTranslate "greater"       = Char '>'-keyTranslate "period"        = Char '.'-keyTranslate "colon"         = Char ':'-keyTranslate "semicolon"     = Char ';'-keyTranslate "comma"         = Char ','-keyTranslate "question"      = Char '?'-keyTranslate "dollar"        = Char '$'-keyTranslate "asterisk"      = Char '*'-keyTranslate "KP_Multiply"   = Char '*'-keyTranslate "slash"         = Char '/'-keyTranslate "KP_Divide"     = Char '/'-keyTranslate "backslash"     = Char '\\'-keyTranslate "underscore"    = Char '_'-keyTranslate "minus"         = Char '-'-keyTranslate "KP_Subtract"   = Char '-'-keyTranslate "plus"          = Char '+'-keyTranslate "KP_Add"        = Char '+'-keyTranslate "equal"         = Char '='-keyTranslate "bracketleft"   = Char '['-keyTranslate "bracketright"  = Char ']'-keyTranslate "braceleft"     = Char '{'-keyTranslate "braceright"    = Char '}'-keyTranslate "apostrophe"    = Char '\''-keyTranslate "Escape"        = Esc-keyTranslate "Return"        = Return-keyTranslate "space"         = Space-keyTranslate "Tab"           = Tab-keyTranslate "ISO_Left_Tab"  = BackTab-keyTranslate "BackSpace"     = BackSpace-keyTranslate "KP_Up"         = Up-keyTranslate "KP_Down"       = Down-keyTranslate "KP_Left"       = Left-keyTranslate "KP_Right"      = Right-keyTranslate "KP_Home"       = Home-keyTranslate "KP_End"        = End-keyTranslate "KP_Page_Up"    = PgUp-keyTranslate "KP_Page_Down"  = PgDn-keyTranslate "KP_Begin"      = Begin-keyTranslate "KP_Enter"      = Return-keyTranslate ['K','P','_',c] = KP c-keyTranslate [c]             = Char c-keyTranslate s               = Unknown $ T.pack s
Game/LambdaHack/Common/Kind.hs view
@@ -17,10 +17,10 @@ import qualified Data.Text as T  import Game.LambdaHack.Common.ContentDef+import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Random-import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind@@ -28,7 +28,6 @@ import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind-import Game.LambdaHack.Utils.Frequency  -- | Content identifiers for the content type @c@. newtype Id c = Id Word8@@ -45,6 +44,7 @@   , isPassableTab :: !Tab   , isDoorTab :: !Tab   , isSuspectTab :: !Tab+  , isChangeableTab :: !Tab   }  newtype Tab = Tab (A.UArray (Id TileKind) Bool)@@ -69,6 +69,8 @@                                     --   and satisfying a predicate   , ofoldrWithKey :: forall b. (Id a -> a -> b -> b) -> b -> b                                     -- ^ fold over all content elements of @a@+  , ofoldrGroup   :: forall b. Text -> (Int -> Id a -> a -> b -> b) -> b -> b+                                    -- ^ fold over the given group only   , obounds       :: !(Id a, Id a)  -- ^ bounds of identifiers of content @a@   , ospeedup      :: !(Maybe (Speedup a))  -- ^ auxiliary speedup components   }@@ -80,15 +82,13 @@   assert (length content <= fromEnum (maxBound :: Id a)) $   let kindMap :: EM.EnumMap (Id a) a       !kindMap = EM.fromDistinctAscList $ zip [Id 0..] content-      kindFreq :: M.Map Text (Frequency (Id a, a))+      kindFreq :: M.Map Text [(Int, (Id a, a))]       kindFreq =         let tuples = [ (cgroup, (n, (i, k)))                      | (i, k) <- EM.assocs kindMap                      , (cgroup, n) <- getFreq k, n > 0 ]             f m (cgroup, nik) = M.insertWith (++) cgroup [nik] m-            lists = foldl' f M.empty tuples-            nameFreq cgroup = toFreq $ "opick ('" <> cgroup <> "')"-        in M.mapWithKey nameFreq lists+        in foldl' f M.empty tuples       okind i = fromMaybe (assert `failure` "no kind" `twith` (i, kindMap))                 $ EM.lookup i kindMap       correct a = not (T.null (getName a)) && all ((> 0) . snd) (getFreq a)@@ -102,20 +102,28 @@            let freq = fromMaybe (assert `failure` "no unique group"                                         `twith` (cgroup, kindFreq))                       $ M.lookup cgroup kindFreq-           in case runFrequency freq of+           in case freq of              [(n, (i, _))] | n > 0 -> i              l -> assert `failure` "not unique" `twith` (l, cgroup, kindFreq)        , opick = \cgroup p ->            case M.lookup cgroup kindFreq of-             Just freq | not $ nullFreq freq -> fmap Just $ frequency $ do-               (i, k) <- freq-               breturn (p k) i-               {- with MonadComprehensions:-               frequency [ i | (i, k) <- kindFreq M.! cgroup, p k ]-               -}+             Just freqRaw ->+               let freq = toFreq ("opick ('" <> cgroup <> "')") freqRaw+               in if nullFreq freq+                  then return Nothing+                  else fmap Just $ frequency $ do+                    (i, k) <- freq+                    breturn (p k) i+                    {- with MonadComprehensions:+                    frequency [ i | (i, k) <- kindFreq M.! cgroup, p k ]+                    -}              _ -> return Nothing        , ofoldrWithKey = \f z -> foldr (\(i, a) -> f i a) 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        , obounds = ( fst $ EM.findMin kindMap                    , fst $ EM.findMax kindMap )        , ospeedup = Nothing  -- define elsewhere@@ -123,12 +131,11 @@  -- | Operations for all content types, gathered together. data COps = COps-  { coactor   :: !(Ops ActorKind)-  , cocave    :: !(Ops CaveKind)+  { cocave    :: !(Ops CaveKind)     -- server only   , cofaction :: !(Ops FactionKind)   , coitem    :: !(Ops ItemKind)-  , comode    :: !(Ops ModeKind)-  , coplace   :: !(Ops PlaceKind)+  , comode    :: !(Ops ModeKind)     -- server only+  , coplace   :: !(Ops PlaceKind)    -- server only, so far   , corule    :: !(Ops RuleKind)   , cotile    :: !(Ops TileKind)   }
+ Game/LambdaHack/Common/LQueue.hs view
@@ -0,0 +1,59 @@+-- | Queues implemented with two stacks to ensure fast writes.+module Game.LambdaHack.Common.LQueue+  ( LQueue+  , newLQueue, nullLQueue, lengthLQueue, tryReadLQueue, writeLQueue+  , trimLQueue, dropStartLQueue, lastLQueue, toListLQueue+  ) where++import Data.Maybe++-- | Queues implemented with two stacks.+type LQueue a = ([a], [a])  -- (read_end, write_end)++-- | Create a new empty mutable queue.+newLQueue :: LQueue a+newLQueue = ([], [])++-- | Check if the queue is empty.+nullLQueue :: LQueue a -> Bool+nullLQueue (rs, ws) = null rs && null ws++-- | The length of the queue.+lengthLQueue :: LQueue a -> Int+lengthLQueue (rs, ws) = length rs + length ws++-- | Try reading a queue. Return @Nothing@ if empty.+tryReadLQueue :: LQueue a -> Maybe (a, LQueue a)+tryReadLQueue (r : rs, ws) = Just (r, (rs, ws))+tryReadLQueue ([], []) = Nothing+tryReadLQueue ([], ws) = tryReadLQueue (reverse ws, [])++-- | Write to the queue. Faster than reading.+writeLQueue :: LQueue a -> a -> LQueue a+writeLQueue (rs, ws) w = (rs, w : ws)++-- | Remove all but the last written non-@Nothing@ element of the queue.+trimLQueue :: LQueue (Maybe a) -> LQueue (Maybe a)+trimLQueue (rs, ws) =+  let trim (_, w:_) = ([w], [])+      trim ([], []) = ([], [])+      trim (rsj, []) = ([last rsj], [])+  in trim (filter isJust rs, filter isJust ws)++-- | Remove frames up to and including the first segment of @Nothing@ frames.+-- | If the resulting queue is empty, apply trimLQueue instead.+dropStartLQueue :: LQueue (Maybe a) -> LQueue (Maybe a)+dropStartLQueue (rs, ws) =+  let dq = (dropWhile isNothing $ dropWhile isJust $ rs ++ reverse ws, [])+  in if nullLQueue dq then trimLQueue (rs, ws) else dq++-- | Dump all but the last written non-@Nothing@ element of the queue, if any.+lastLQueue :: LQueue (Maybe a) -> Maybe a+lastLQueue (rs, ws) =+  let lst (_, w:_) = Just w+      lst ([], []) = Nothing+      lst (rsj, []) = Just $ last rsj+  in lst (catMaybes rs, catMaybes ws)++toListLQueue :: LQueue a -> [a]+toListLQueue (rs, ws) = rs ++ reverse ws
Game/LambdaHack/Common/Level.hs view
@@ -1,19 +1,14 @@-{-# LANGUAGE DeriveGeneric #-} -- | Inhabited dungeon levels and the operations to query and change them -- as the game progresses. module Game.LambdaHack.Common.Level   ( -- * Dungeon-    LevelId, Dungeon, ascendInBranch-    -- * Item containers-  , Container(..)+    LevelId, AbsDepth, Dungeon, ascendInBranch     -- * The @Level@ type and its components-  , SmellMap, ItemFloor, TileMap-  , Level(..)-    -- * Level update-  , updatePrio, updateSmell, updateFloor, updateTile+  , Level(..), ActorPrio, ItemFloor, TileMap, SmellMap     -- * Level query-  , at, atI, checkAccess, checkDoorAccess, accessible, accessibleDir-  , isSecretPos, hideTile+  , at, atI, checkAccess, checkDoorAccess+  , accessible, accessibleUnknown, accessibleDir+  , knownLsecret, isSecretPos, hideTile   , findPos, findPosTry, mapLevelActors_, mapDungeonActors_  ) where @@ -23,9 +18,9 @@ import qualified Data.EnumMap.Strict as EM import Data.Maybe import Data.Text (Text)-import GHC.Generics (Generic)  import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point@@ -37,7 +32,6 @@ import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind-import Game.LambdaHack.Utils.Frequency  -- | The complete dungeon is a map from level names to levels. type Dungeon = EM.EnumMap LevelId Level@@ -53,15 +47,8 @@       ln = max minD $ min maxD $ toEnum $ fromEnum lid + k   in case EM.lookup ln dungeon of     Just _ | ln /= lid -> [ln]-    _ -> []---- | Item container type.-data Container =-    CFloor !LevelId !Point-  | CActor !ActorId !InvChar-  deriving (Show, Eq, Ord, Generic)--instance Binary Container+    _ | ln == lid -> []+    _ -> ascendInBranch dungeon k ln  -- jump over gaps  -- | Actor time priority queue. type ActorPrio = EM.EnumMap Time [ActorId]@@ -78,45 +65,28 @@ -- | A view on single, inhabited dungeon level. "Remembered" fields -- carry a subset of the info in the client copies of levels. data Level = Level-  { ldepth    :: !Int        -- ^ depth of the level-  , lprio     :: !ActorPrio  -- ^ remembered actor times on the level-  , lfloor    :: !ItemFloor  -- ^ remembered items lying on the floor-  , ltile     :: !TileMap    -- ^ remembered level map-  , lxsize    :: !X          -- ^ width of the level-  , lysize    :: !Y          -- ^ height of the level-  , lsmell    :: !SmellMap   -- ^ remembered smells on the level-  , ldesc     :: !Text       -- ^ level description-  , lstair    :: !([Point], [Point])-                             -- ^ destinations of (up, down) stairs-  , lseen     :: !Int        -- ^ currently remembered clear tiles-  , lclear    :: !Int        -- ^ total number of initially clear tiles;-                             --   set to 1 on clients when fully explored-  , ltime     :: !Time       -- ^ date of the last activity on the level-  , litemNum  :: !Int        -- ^ number of initial items, 0 for clients-  , litemFreq :: !(Frequency Text)  -- ^ frequency of initial items,-                                    --   [] for clients-  , lsecret   :: !Int        -- ^ secret tile seed-  , lhidden   :: !Int        -- ^ secret tile density-  , lescape   :: !Bool       -- ^ has an Effect.Escape tile+  { ldepth     :: !AbsDepth   -- ^ absolute depth of the level+  , lprio      :: !ActorPrio  -- ^ remembered actor times on the level+  , lfloor     :: !ItemFloor  -- ^ remembered items lying on the floor+  , ltile      :: !TileMap    -- ^ remembered level map+  , lxsize     :: !X          -- ^ width of the level+  , lysize     :: !Y          -- ^ height of the level+  , lsmell     :: !SmellMap   -- ^ remembered smells on the level+  , ldesc      :: !Text       -- ^ level description+  , lstair     :: !([Point], [Point])+                              -- ^ destinations of (up, down) stairs+  , lseen      :: !Int        -- ^ currently remembered clear tiles+  , lclear     :: !Int        -- ^ total number of initially clear tiles+  , ltime      :: !Time       -- ^ date of the last activity on the level+  , lactorFreq :: !Freqs      -- ^ frequency of spawned actors; [] for clients+  , litemNum   :: !Int        -- ^ number of initial items, 0 for clients+  , litemFreq  :: !Freqs      -- ^ frequency of initial items; [] for clients+  , lsecret    :: !Int        -- ^ secret tile seed+  , lhidden    :: !Int        -- ^ secret tile density+  , lescape    :: !Bool       -- ^ has an Effect.Escape tile   }   deriving (Show, Eq) --- | Update the actor time priority queue.-updatePrio :: (ActorPrio -> ActorPrio) -> Level -> Level-updatePrio f lvl = lvl {lprio = f (lprio lvl)}---- | Update the smell map.-updateSmell :: (SmellMap -> SmellMap) -> Level -> Level-updateSmell f lvl = lvl {lsmell = f (lsmell lvl)}---- | Update the items on the ground map.-updateFloor :: (ItemFloor -> ItemFloor) -> Level -> Level-updateFloor f lvl = lvl {lfloor = f (lfloor lvl)}---- | Update the tile map.-updateTile :: (TileMap -> TileMap) -> Level -> Level-updateTile f lvl = lvl {ltile = f (ltile lvl)}- assertSparseItems :: ItemFloor -> ItemFloor assertSparseItems m =   assert (EM.null (EM.filter EM.null m)@@ -159,15 +129,32 @@                              , checkDoorAccess cops lvl ]   in \spos tpos -> all (\f -> f spos tpos) conditions +-- | Check whether one position is accessible from another,+-- using the formula from the standard ruleset,+-- but additionally treating unknown tiles as walkable.+-- Precondition: the two positions are next to each other.+accessibleUnknown :: Kind.COps -> Level -> Point -> Point -> Bool+accessibleUnknown cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} lvl =+  let unknownId = ouniqGroup "unknown space"+      checkWalkability =+        Just $ \_ tpos -> let t = lvl `at` tpos+                          in Tile.isWalkable cotile t || t == unknownId+      conditions = catMaybes [ checkWalkability+                             , checkAccess cops lvl+                             , checkDoorAccess cops lvl ]+  in \spos tpos -> all (\f -> f spos tpos) conditions+ -- | Check whether actors can move from a position along a unit vector, -- using the formula from the standard ruleset. accessibleDir :: Kind.COps -> Level -> Point -> Vector -> Bool accessibleDir cops lvl spos dir = accessible cops lvl spos $ spos `shift` dir +knownLsecret :: Level -> Bool+knownLsecret lvl = lsecret lvl /= 0+ isSecretPos :: Level -> Point -> Bool-isSecretPos lvl p =-  (lsecret lvl `Bits.rotateR` fromEnum p `Bits.xor` fromEnum p)-  `mod` lhidden lvl == 0+isSecretPos lvl (Point x y) =+  (lsecret lvl `Bits.rotateR` x `Bits.xor` y + x) `mod` lhidden lvl == 0  hideTile :: Kind.Ops TileKind -> Level -> Point -> Kind.Id TileKind hideTile cotile lvl p =@@ -238,6 +225,7 @@     put lseen     put lclear     put ltime+    put lactorFreq     put litemNum     put litemFreq     put lsecret@@ -256,6 +244,7 @@     lseen <- get     lclear <- get     ltime <- get+    lactorFreq <- get     litemNum <- get     litemFreq <- get     lsecret <- get
Game/LambdaHack/Common/Misc.hs view
@@ -1,9 +1,14 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Hacks that haven't found their home yet. module Game.LambdaHack.Common.Misc-  ( normalLevelBound, divUp, Freqs, breturn-  , FactionId, LevelId+  ( -- * Game object identifiers+    FactionId, LevelId, AbsDepth(..), ActorId+    -- * Item containers+  , Container(..), CStore(..)+    -- * Assorted+  , normalLevelBound, divUp, Freqs, breturn+  , serverSaveName, nearby   ) where  import Control.Monad@@ -11,12 +16,22 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Functor-import qualified Data.Hashable as Hashable+import Data.Hashable import qualified Data.HashMap.Strict as HM import Data.Key import Data.Text (Text) import Data.Traversable (traverse)+import GHC.Generics (Generic) +import Game.LambdaHack.Common.Point++-- | What distance signifies that two actors are "nearby".+nearby :: Int+nearby = 10++serverSaveName :: String+serverSaveName = "server.sav"+ -- | Level bounds. TODO: query terminal size instead and scroll view. normalLevelBound :: (Int, Int) normalLevelBound = (79, 20)@@ -36,19 +51,64 @@ breturn True a  = return a breturn False _ = mzero +-- | Item container type.+data Container =+    CFloor !LevelId !Point+  | CActor !ActorId !CStore+  | CTrunk !FactionId !LevelId !Point   -- ^ for bootstrapping actor bodies+  deriving (Show, Eq, Ord, Generic)++instance Binary Container++data CStore =+    CGround+  | COrgan+  | CEqp+  | CInv+  | CSha+  deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)++instance Binary CStore++instance Hashable CStore++-- | A unique identifier of a faction in a game.+newtype FactionId = FactionId Int+  deriving (Show, Eq, Ord, Enum, Binary)++-- | Abstract level identifiers.+newtype LevelId = LevelId Int+  deriving (Show, Eq, Ord, Enum, Hashable, Binary)++-- | Absolute depth in the dungeon. When used for the maximum depth+-- of the whole dungeon, this can be different than dungeon size,+-- e.g., when the dungeon is branched, and it can even be different+-- than the length of the longest branch, if levels at some depths are missing.+newtype AbsDepth = AbsDepth Int+  deriving (Show, Eq, Ord, Hashable, Binary)++-- | A unique identifier of an actor in the dungeon.+newtype ActorId = ActorId Int+  deriving (Show, Eq, Ord, Enum, Binary)+ -- Data.Binary  instance (Enum k, Binary k, Binary e) => Binary (EM.EnumMap k e) where+  {-# INLINEABLE put #-}   put m = put (EM.size m) >> mapM_ put (EM.toAscList m)+  {-# INLINEABLE get #-}   get = liftM EM.fromDistinctAscList get  instance (Enum k, Binary k) => Binary (ES.EnumSet k) where+  {-# INLINEABLE put #-}   put m = put (ES.size m) >> mapM_ put (ES.toAscList m)+  {-# INLINEABLE get #-}   get = liftM ES.fromDistinctAscList get -instance (Binary k, Binary v, Eq k, Hashable.Hashable k)-  => Binary (HM.HashMap k v) where+instance (Binary k, Binary v, Eq k, Hashable k) => Binary (HM.HashMap k v) where+  {-# INLINEABLE put #-}   put ir = put $ HM.toList ir+  {-# INLINEABLE get #-}   get = fmap HM.fromList get  -- Data.Key@@ -80,18 +140,8 @@ instance Enum k => Adjustable (EM.EnumMap k) where   adjust = EM.adjust --- | A unique identifier of a faction in a game.-newtype FactionId = FactionId Int-  deriving (Show, Eq, Ord, Enum)--instance Binary FactionId where-  put (FactionId n) = put n-  get = fmap FactionId get---- | Abstract level identifiers.-newtype LevelId = LevelId Int-  deriving (Show, Eq, Ord, Enum)+-- Data.Hashable -instance Binary LevelId where-  put (LevelId n) = put n-  get = fmap LevelId get+instance (Enum k, Hashable k, Hashable e) => Hashable (EM.EnumMap k e) where+  {-# INLINEABLE hashWithSalt #-}+  hashWithSalt s x = hashWithSalt s (EM.toAscList x)
+ Game/LambdaHack/Common/MonadStateRead.hs view
@@ -0,0 +1,41 @@+-- | Game action monads and basic building blocks for human and computer+-- player actions. Has no access to the the main action type.+module Game.LambdaHack.Common.MonadStateRead+  ( MonadStateRead(..)+  , getLevel, nUI, posOfAid, fightsAgainstSpawners+  ) where++import qualified Data.EnumMap.Strict as EM++import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.ModeKind++class (Monad m, Functor m) => MonadStateRead m where+  getState  :: m State+  getsState :: (State -> a) -> m a++getLevel :: MonadStateRead m => LevelId -> m Level+getLevel lid = getsState $ (EM.! lid) . sdungeon++nUI :: MonadStateRead m => m Int+nUI = do+  factionD <- getsState sfactionD+  return $! length $ filter (playerUI . gplayer) $ EM.elems factionD++posOfAid :: MonadStateRead m => ActorId -> m (LevelId, Point)+posOfAid aid = do+  b <- getsState $ getActorBody aid+  return (blid b, bpos b)++-- TODO: make a field of Faction?+fightsAgainstSpawners :: MonadStateRead m => FactionId -> m Bool+fightsAgainstSpawners fid = do+  fact <- getsState $ (EM.! fid) . sfactionD+  dungeon <- getsState sdungeon+  let escape = any lescape $ EM.elems dungeon+  return $! escape && keepArenaFact fact
Game/LambdaHack/Common/Msg.hs view
@@ -4,23 +4,30 @@   ( makePhrase, makeSentence   , Msg, (<>), (<+>), tshow, toWidth, moreMsg, yesnoMsg, truncateMsg   , Report, emptyReport, nullReport, singletonReport, addMsg-  , splitReport, renderReport, findInReport-  , History, emptyHistory, singletonHistory, mergeHistory-  , addReport, renderHistory, takeHistory+  , splitReport, renderReport, findInReport, lastMsgOfReport+  , History, emptyHistory, lengthHistory, singletonHistory, mergeHistory+  , addReport, renderHistory, takeHistory, lastReportOfHistory   , Overlay(overlay), emptyOverlay, truncateToOverlay, toOverlay-  , Slideshow(slideshow), splitOverlay, toSlideshow)+  , Slideshow(slideshow), splitOverlay, toSlideshow+  , encodeLine, encodeOverlay, ScreenLine, toScreenLine, splitText+  )   where +import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.ByteString.Char8 as BS+import Data.Int (Int32) import Data.List import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8, encodeUtf8)+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 import Game.LambdaHack.Common.Point @@ -97,7 +104,7 @@ -- | Split a messages into chunks that fit in one line. -- We assume the width of the messages line is the same as of level map. splitReport :: X -> Report -> Overlay-splitReport w r = Overlay $ splitReportList w r+splitReport w r = toOverlay $ splitReportList w r  splitReportList :: X -> Report -> [Text] splitReportList w r = splitText w $ renderReport r@@ -115,6 +122,12 @@ findInReport :: (BS.ByteString -> Bool) -> Report -> Maybe BS.ByteString findInReport f (Report xns) = find f $ map fst xns +lastMsgOfReport :: Report -> (BS.ByteString, Report)+lastMsgOfReport (Report rep) = case rep of+  [] -> assert `failure` rep+  (lmsg, 1) : repRest -> (lmsg, Report repRest)+  (lmsg, n) : repRest -> (lmsg, Report $ (lmsg, n - 1) : repRest)+ -- | Split a string into lines. Avoids ending the line with a character -- other than whitespace or punctuation. Space characters are removed -- from the start, but never from the end of lines. Newlines are respected.@@ -140,6 +153,9 @@ emptyHistory :: History emptyHistory = History [] +lengthHistory :: History -> Int+lengthHistory (History rs) = length rs+ -- | Construct a singleton history of reports. singletonHistory :: Report -> History singletonHistory r = addReport r emptyHistory@@ -154,7 +170,7 @@ renderHistory :: History -> Overlay renderHistory (History h) =   let w = fst normalLevelBound + 1-  in Overlay $ concatMap (splitReportList w) h+  in toOverlay $ concatMap (splitReportList w) h  -- | Add a report to history, handling repetitions. addReport :: Report -> History -> History@@ -171,33 +187,56 @@ takeHistory :: Int -> History -> History takeHistory k (History h) = History $ take k h +lastReportOfHistory :: History -> Maybe Report+lastReportOfHistory (History hist) = case hist of+  [] -> Nothing+  rep : _ -> Just rep++type ScreenLine = U.Vector Int32++toScreenLine :: Text -> ScreenLine+toScreenLine t = let f c = AttrChar defAttr c+                 in encodeLine $ map f $ T.unpack t++encodeLine :: [AttrChar] -> ScreenLine+encodeLine l = G.fromList $ map (fromIntegral . fromEnum) l++encodeOverlay :: [[AttrChar]] -> Overlay+encodeOverlay = Overlay . map encodeLine+ -- | A series of screen lines that may or may not fit the width nor height -- of the screen. An overlay may be transformed by adding the first line -- and/or by splitting into a slideshow of smaller overlays.-newtype Overlay = Overlay {overlay :: [Text]}+newtype Overlay = Overlay {overlay :: [ScreenLine]}   deriving (Show, Eq, Binary)  emptyOverlay :: Overlay emptyOverlay = Overlay [] -truncateToOverlay :: X -> Text -> Overlay-truncateToOverlay lxsize msg = Overlay [truncateMsg lxsize msg]+truncateToOverlay :: Text -> Overlay+truncateToOverlay msg = toOverlay [msg]  toOverlay :: [Text] -> Overlay-toOverlay = Overlay+toOverlay = let lxsize = fst normalLevelBound + 1  -- TODO+            in Overlay . map toScreenLine . map (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 onBlank yspace (Overlay msg) (Overlay ls) =-  let over = msg ++ ls-  in if length over <= yspace-     then Slideshow (onBlank, [Overlay over])  -- all fits on one screen-     else let (pre, post) = splitAt (yspace - 1) over-              Slideshow (_, slides) =-                splitOverlay onBlank yspace (Overlay msg) (Overlay post)-          in Slideshow $ (onBlank, (Overlay $ pre ++ [moreMsg]) : slides)+  let len = length msg+  in if len >= yspace+     then  -- no space left for @ls@+       Slideshow (onBlank, [Overlay $ take (yspace - 1) msg+                                      ++ [toScreenLine moreMsg]])+     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+                   else let rest = splitO post+                        in Overlay (pre ++ [toScreenLine moreMsg]) : rest+          in Slideshow (onBlank, splitO ls)  -- | A few overlays, displayed one by one upon keypress. -- When displayed, they are trimmed, not wrapped@@ -205,7 +244,7 @@ -- If the boolean flag is set, the overlay is displayed over a blank screen, -- including the bottom lines. newtype Slideshow = Slideshow {slideshow :: (Bool, [Overlay])}-  deriving Show+  deriving (Show, Eq)  instance Monoid Slideshow where   mempty = Slideshow (False, [])@@ -217,4 +256,4 @@ -- or contained in the overlays and if any vertical or horizontal -- trimming of the overlays happens, this is intended. toSlideshow :: Bool -> [[Text]] -> Slideshow-toSlideshow onBlank l = Slideshow (onBlank, map Overlay l)+toSlideshow onBlank l = Slideshow (onBlank, map toOverlay l)
Game/LambdaHack/Common/PointArray.hs view
@@ -2,7 +2,7 @@ module Game.LambdaHack.Common.PointArray   ( Array   , (!), (//), replicateA, replicateMA, generateMA, sizeA-  , foldlA, ifoldlA, minIndexA, minLastIndexA, maxIndexA, maxLastIndexA+  , foldlA, ifoldlA, imapA, minIndexA, minLastIndexA, maxIndexA, maxLastIndexA   ) where  import Control.Arrow ((***))@@ -86,6 +86,12 @@ ifoldlA :: Enum c => (a -> Point -> c -> a) -> a -> Array c -> a ifoldlA f z0 Array{..} =   U.ifoldl' (\a n c -> f a (punindex axsize n) (cnv c)) z0 avector++-- | Map over an array (function applied to each element and its index).+imapA :: (Enum c, Enum d) => (Point -> c -> d) -> Array c -> Array d+imapA f Array{..} =+  let v = U.imap (\n c -> cnv $ f (punindex axsize n) (cnv c)) avector+  in Array{avector = v, ..}  -- | Yield the point coordinates of a minimum element of the array. -- The array may not be empty.
Game/LambdaHack/Common/Random.hs view
@@ -4,29 +4,21 @@   ( -- * The @Rng@ monad     Rnd     -- * Random operations-  , randomR, random, oneOf, frequency, cast-    -- * Casting dice-  , RollDice, rollDice, castDice, maxDice, minDice, meanDice-    -- * Casting 2D coordinates-  , RollDiceXY, rollDiceXY, castDiceXY, maxDiceXY, minDiceXY, meanDiceXY-    -- * Casting dependent on depth-  , RollDeep, rollDeep, castDeep, chanceDeep, intToDeep, maxDeep+  , randomR, random, oneOf, frequency     -- * Fractional chance   , Chance, chance-    -- * Run using the IO RNG-  , rndToIO+    -- * Casting dice scaled with level+  , castDice, chanceDice, castDiceXY   ) where  import Control.Exception.Assert.Sugar-import Control.Monad import qualified Control.Monad.State as St-import Data.Binary-import qualified Data.Hashable as Hashable import Data.Ratio-import GHC.Generics (Generic) import qualified System.Random as R -import Game.LambdaHack.Utils.Frequency+import qualified Game.LambdaHack.Common.Dice as Dice+import Game.LambdaHack.Common.Frequency+import Game.LambdaHack.Common.Misc  -- | The monad of computations with random generator state. -- The lazy state monad is OK here: the state is small and regularly forced.@@ -51,132 +43,24 @@ frequency :: Show a => Frequency a -> Rnd a frequency fr = St.state $ rollFreq fr --- | Cast a single die.-cast :: Int -> Rnd Int-cast x = if x <= 0 then return 0 else randomR (1, x)---- | Dice: 1d7, 3d3, 1d0, etc.--- @RollDice a b@ represents @a@ rolls of @b@-sided die.-data RollDice = RollDice !Word8 !Word8-  deriving (Eq, Ord, Generic)--instance Show RollDice where-  show (RollDice a b) = show a ++ "d" ++ show b--instance Read RollDice where-  readsPrec d s =-    let (a, db) = break (== 'd') s-        av = read a-    in case db of-      'd' : b -> [ (RollDice av bv, rest) | (bv, rest) <- readsPrec d b ]-      _ -> []--instance Hashable.Hashable RollDice--instance Binary RollDice--rollDice :: Int -> Int -> RollDice-rollDice a b = assert (a >= 0 && a <= 255 && b >= 0 && b <= 255-                       `blame` "dice out of bounds" `twith` (a, b))-               $ RollDice (toEnum a) (toEnum b)---- | Cast dice and sum the results.-castDice :: RollDice -> Rnd Int-castDice (RollDice a' 1)  = return $! fromEnum a'  -- optimization-castDice (RollDice a' b') =-  let (a, b) = (fromEnum a', fromEnum b')-  in liftM sum (replicateM a (cast b))---- | Maximal value of dice.-maxDice :: RollDice -> Int-maxDice (RollDice a' b') =-  let (a, b) = (fromEnum a', fromEnum b')-  in a * b---- | Minimal value of dice.-minDice :: RollDice -> Int-minDice (RollDice a' b') =-  let (a, b) = (fromEnum a', fromEnum b')-  in if b == 0 then 0 else a---- | Mean value of dice.-meanDice :: RollDice -> Rational-meanDice (RollDice a' b') =-  let (a, b) = (fromIntegral a', fromIntegral b')-  in if b' == 0 then 0 else a * (b + 1) % 2---- | Dice for rolling a pair of integer parameters pertaining to,--- respectively, the X and Y cartesian 2D coordinates.-data RollDiceXY = RollDiceXY ![RollDice] ![RollDice]-  deriving Show--rollDiceXY :: [(Int, Int)] -> [(Int, Int)] -> RollDiceXY-rollDiceXY lx ly = RollDiceXY (map (uncurry rollDice) lx)-                              (map (uncurry rollDice) ly)---- | Cast the two sets of dice.-castDiceXY :: RollDiceXY -> Rnd (Int, Int)-castDiceXY (RollDiceXY lx ly) = do-  cx <- mapM castDice lx-  cy <- mapM castDice ly-  return (sum cx, sum cy)---- | Maximal value of RollDiceXY.-maxDiceXY :: RollDiceXY -> (Int, Int)-maxDiceXY (RollDiceXY lx ly) = (sum (map maxDice lx), sum (map maxDice ly))---- | Minimal value of RollDiceXY.-minDiceXY :: RollDiceXY -> (Int, Int)-minDiceXY (RollDiceXY lx ly) = (sum (map minDice lx), sum (map minDice ly))---- | Mean value of RollDiceXY.-meanDiceXY :: RollDiceXY -> (Rational, Rational)-meanDiceXY (RollDiceXY lx ly) = (sum (map meanDice lx), sum (map meanDice ly))---- | Dice for parameters scaled with current level depth.--- To the result of rolling the first set of dice we add the second,--- scaled in proportion to current depth divided by maximal dungeon depth.-data RollDeep = RollDeep !RollDice !RollDice-  deriving (Show, Eq, Ord, Generic)--instance Binary RollDeep--rollDeep :: (Int, Int) -> (Int, Int) -> RollDeep-rollDeep (a, b) (c, d) = RollDeep (rollDice a b) (rollDice c d)---- | Cast dice scaled with current level depth.--- Note that at the first level, the scaled dice are always ignored.-castDeep :: Int -> Int -> RollDeep -> Rnd Int-castDeep n' depth' (RollDeep d1 d2) = do-  let n = abs n'-      depth = abs depth'-  assert (n > 0 && n <= depth `blame` "invalid current depth for dice rolls"-                              `twith` (n, depth)) skip-  r1 <- castDice d1-  r2 <- castDice d2-  return $! r1 + ((n - 1) * r2) `div` max 1 (depth - 1)---- | Cast dice scaled with current level depth and return @True@--- if the results if greater than 50.-chanceDeep :: Int -> Int -> RollDeep -> Rnd Bool-chanceDeep n' depth' deep = do-  let n = abs n'-      depth = abs depth'-  c <- castDeep n depth deep-  return $! c > 50---- | Generate a @RollDeep@ that always gives a constant integer.-intToDeep :: Int -> RollDeep-intToDeep 0  = RollDeep (RollDice 0 0) (RollDice 0 0)-intToDeep n' = if n' > fromEnum (maxBound :: Word8)-                  || n' < fromEnum (minBound :: Word8)-               then assert `failure` "Deep out of bound" `twith` n'-               else let n = toEnum n'-                    in RollDeep (RollDice n 1) (RollDice 0 0)---- | Maximal value of scaled dice.-maxDeep :: RollDeep -> Int-maxDeep (RollDeep d1 d2) = maxDice d1 + maxDice d2+-- | Randomly choose an item according to the distribution.+rollFreq :: Show a => Frequency a -> R.StdGen -> (a, R.StdGen)+rollFreq fr g = case runFrequency fr of+  [] -> assert `failure` "choice from an empty frequency"+               `twith` nameFrequency fr+  [(n, x)] | n <= 0 -> assert `failure` "singleton void frequency"+                                 `twith` (nameFrequency fr, n, x)+  [(_, x)] -> (x, g)  -- speedup+  fs -> let sumf = sum (map fst fs)+            (r, ng) = R.randomR (1, sumf) g+            frec :: Int -> [(Int, a)] -> a+            frec m [] = assert `failure` "impossible roll"+                               `twith` (nameFrequency fr, fs, m)+            frec m ((n, x) : _)  | m <= n = x+            frec m ((n, _) : xs) = frec (m - n) xs+        in assert (sumf > 0 `blame` "frequency with nothing to pick"+                            `twith` (nameFrequency fr, fs))+             (frec r fs, ng)  -- | Fractional chance. type Chance = Rational@@ -189,9 +73,27 @@   k <- randomR (1, d)   return (k <= n) -rndToIO :: Rnd a -> IO a-rndToIO r = do-  g <- R.getStdGen-  let (x, ng) = St.runState r g-  R.setStdGen ng-  return x+-- | Cast dice scaled with current level depth.+-- Note that at the first level, the scaled dice are always ignored.+castDice :: AbsDepth -> AbsDepth -> Dice.Dice -> Rnd Int+castDice (AbsDepth n) (AbsDepth depth) dice = do+  assert (n >= 0 && n <= depth `blame` "invalid depth for dice rolls"+                               `twith` (n, depth)) skip+  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++-- | Cast dice scaled with current level depth and return @True@+-- if the results is greater than 50.+chanceDice :: AbsDepth -> AbsDepth -> Dice.Dice -> Rnd Bool+chanceDice ldepth totalDepth dice = do+  c <- castDice ldepth totalDepth dice+  return $! c > 50++-- | Cast dice, scaled with current level depth, for coordinates.+castDiceXY :: AbsDepth -> AbsDepth -> Dice.DiceXY -> Rnd (Int, Int)+castDiceXY ldepth totalDepth (Dice.DiceXY dx dy) = do+  x <- castDice ldepth totalDepth dx+  y <- castDice ldepth totalDepth dy+  return (x, y)
+ Game/LambdaHack/Common/Request.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE ExistentialQuantification, GADTs, StandaloneDeriving, DataKinds, KindSignatures #-}+-- | Abstract syntax of server commands.+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Common.Request+  ( RequestAI(..), RequestUI(..), RequestTimed(..), RequestAnyAbility(..)+  , ReqFailure(..), showReqFailure, anyToUI+  ) where++import Data.Text (Text)++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Common.Ability++-- TODO: make remove second arg from ReqLeader; this requires a separate+-- channel for Ping, probably, and then client sends as many commands+-- as it wants at once+-- | Cclient-server requests sent by AI clients.+data RequestAI =+    forall a. ReqAITimed !(RequestTimed a)+  | ReqAILeader !ActorId !RequestAI+  | ReqAIPong++deriving instance Show RequestAI++-- | Client-server requests sent by UI clients.+data RequestUI =+    forall a. ReqUITimed !(RequestTimed a)+  | ReqUILeader !ActorId !RequestUI+  | ReqUIGameRestart !ActorId !Text !Int ![(Int, (Text, Text))]+  | ReqUIGameExit !ActorId !Int+  | ReqUIGameSave+  | ReqUIAutomate+  | ReqUIPong [CmdAtomic]++deriving instance Show RequestUI++data RequestAnyAbility = forall a. RequestAnyAbility !(RequestTimed a)++deriving instance Show RequestAnyAbility++anyToUI :: RequestAnyAbility -> RequestUI+anyToUI (RequestAnyAbility cmd) = ReqUITimed cmd++-- | 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 F.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 F.Feature) -> RequestTimed AbTrigger++deriving instance Show (RequestTimed a)++data ReqFailure =+    MoveNothing+  | MeleeSelf+  | MeleeDistant+  | DisplaceDistant+  | DisplaceAccess+  | DisplaceProjectiles+  | DisplaceDying+  | DisplaceBraced+  | DisplaceSupported+  | AlterDistant+  | AlterBlockActor+  | AlterBlockItem+  | AlterNothing+  | EqpOverfull+  | DurablePeriodicAbuse+  | ApplyBlind+  | ApplyOutOfReach+  | ItemNothing+  | ItemNotCalm+  | ProjectAimOnself+  | ProjectBlockTerrain+  | ProjectBlockActor+  | ProjectBlind+  | TriggerNothing++showReqFailure :: ReqFailure -> Msg+showReqFailure reqFailure = case reqFailure of+  MoveNothing -> "wasting time on moving into obstacle"+  MeleeSelf -> "trying to melee oneself"+  MeleeDistant -> "trying to melee a distant foe"+  DisplaceDistant -> "trying to switch places with a distant actor"+  DisplaceAccess -> "switching places without access"+  DisplaceProjectiles -> "trying to switch places with multiple projectiles"+  DisplaceDying -> "trying to switch places with a dying foe"+  DisplaceBraced -> "trying to switch places with a braced foe"+  DisplaceSupported -> "trying to switch places with 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"+  DurablePeriodicAbuse -> "cannot apply a durable periodic item"+  ApplyBlind -> "blind actors cannot read"+  ApplyOutOfReach -> "cannot apply an item out of reach"+  ItemNothing -> "wasting time on void item manipulation"+  ItemNotCalm -> "you are too alarmed to sort through the shared stash"+  ProjectAimOnself -> "cannot aim at oneself"+  ProjectBlockTerrain -> "aiming obstructed by terrain"+  ProjectBlockActor -> "aiming blocked by an actor"+  ProjectBlind -> "blind actors cannot aim"+  TriggerNothing -> "wasting time on triggering nothing"
+ Game/LambdaHack/Common/Response.hs view
@@ -0,0 +1,24 @@+-- | Abstract syntax of client commands.+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Common.Response+  ( ResponseAI(..), ResponseUI(..)+  ) where++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor++-- | Abstract syntax of client commands that don't use the UI.+data ResponseAI =+    RespUpdAtomicAI !UpdAtomic+  | RespQueryAI !ActorId+  | RespPingAI+  deriving Show++-- | Abstract syntax of client commands that use the UI.+data ResponseUI =+    RespUpdAtomicUI !UpdAtomic+  | RespSfxAtomicUI !SfxAtomic+  | RespQueryUI+  | RespPingUI+  deriving Show
Game/LambdaHack/Common/Save.hs view
@@ -4,6 +4,7 @@   ) where  import Control.Concurrent+import Control.Concurrent.Async import qualified Control.Exception as Ex hiding (handle) import Control.Monad import Data.Binary@@ -15,9 +16,8 @@ import System.IO import qualified System.Random as R +import Game.LambdaHack.Common.File import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Utils.File-import Game.LambdaHack.Utils.Thread  type ChanSave a = MVar (Maybe a) @@ -58,15 +58,16 @@   -- We don't merge this with the other calls to waitForChildren,   -- because, e.g., for server, we don't want to wait for clients to exit,   -- if the server crashes (but we wait for the save to finish).-  children <- newMVar []   toSave <- newEmptyMVar-  void $ forkChild children $ loopSave saveFile toSave+  a <- async $ loopSave saveFile toSave+  link a   let fin = do         -- Wait until the last save (if any) starts         -- and tell the save thread to end.         putMVar toSave Nothing-        -- Wait until the save thread ends.-        waitForChildren children+        -- Wait 0.5s to flush debug and then until the save thread ends.+        threadDelay 500000+        wait a   exe toSave `Ex.finally` fin   -- The creation of, e.g., the initial client state, is outside the 'finally'   -- clause, but this is OK, since no saves are ordered until 'runActionCli'.@@ -109,6 +110,6 @@ delayPrint :: Text -> IO () delayPrint t = do   delay <- R.randomRIO (0, 1000000)-  threadDelay delay  -- try not to interleave letters with other clients+  threadDelay delay  -- try not to interleave saves with other clients   T.hPutStrLn stderr t   hFlush stderr
− Game/LambdaHack/Common/ServerCmd.hs 
@@ -1,101 +0,0 @@--- | Abstract syntax of server commands.--- See--- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Common.ServerCmd-  ( CmdSer(..), CmdTakeTimeSer(..), aidCmdSer, aidCmdTakeTimeSer-  , FailureSer(..), showFailureSer-  ) where--import Data.Text (Text)--import Game.LambdaHack.Common.Actor-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Vector---- | Abstract syntax of server commands.-data CmdSer =-    CmdTakeTimeSer !CmdTakeTimeSer-  | GameRestartSer !ActorId !Text !Int ![(Int, Text)]-  | GameExitSer !ActorId !Int-  | GameSaveSer !ActorId-  deriving (Show, Eq)--data CmdTakeTimeSer =-    MoveSer !ActorId !Vector-  | MeleeSer !ActorId !ActorId-  | DisplaceSer !ActorId !ActorId-  | AlterSer !ActorId !Point !(Maybe F.Feature)-  | WaitSer !ActorId-  | PickupSer !ActorId !ItemId !Int-  | DropSer !ActorId !ItemId !Int-  | ProjectSer !ActorId !Point !Int !ItemId !Container-  | ApplySer !ActorId !ItemId !Container-  | TriggerSer !ActorId !(Maybe F.Feature)-  | SetTrajectorySer !ActorId-  deriving (Show, Eq)---- | The actor that starts performing the command (may be dead, after--- the command is performed).-aidCmdSer :: CmdSer -> ActorId-aidCmdSer cmd = case cmd of-  CmdTakeTimeSer cmd2 -> aidCmdTakeTimeSer cmd2-  GameRestartSer aid _ _ _ -> aid-  GameExitSer aid _ -> aid-  GameSaveSer aid -> aid--aidCmdTakeTimeSer :: CmdTakeTimeSer -> ActorId-aidCmdTakeTimeSer cmd = case cmd of-  MoveSer aid _ -> aid-  MeleeSer aid _ -> aid-  DisplaceSer aid _ -> aid-  AlterSer aid _ _ -> aid-  WaitSer aid -> aid-  PickupSer aid _ _ -> aid-  DropSer aid _ _ -> aid-  ProjectSer aid _ _ _ _ -> aid-  ApplySer aid _ _ -> aid-  TriggerSer aid _ -> aid-  SetTrajectorySer aid -> aid--data FailureSer =-    MoveNothing-  | MeleeSelf-  | MeleeDistant-  | DisplaceDistant-  | DisplaceAccess-  | DisplaceProjectiles-  | AlterDistant-  | AlterBlockActor-  | AlterBlockItem-  | AlterNothing-  | PickupOverfull-  | ProjectAimOnself-  | ProjectBlockTerrain-  | ProjectBlockActor-  | ProjectBlockFoes-  | ProjectBlind-  | TriggerNothing--showFailureSer :: FailureSer -> Msg-showFailureSer failureSer = case failureSer of-  MoveNothing -> "wasting time on moving into obstacle"-  MeleeSelf -> "trying to melee oneself"-  MeleeDistant -> "trying to melee a distant foe"-  DisplaceDistant -> "trying to switch places with a distant actor"-  DisplaceAccess -> "switching places without access"-  DisplaceProjectiles -> "trying to switch places with multiple projectiles"-  AlterDistant -> "trying to alter a distant tile"-  AlterBlockActor -> "blocked by an actor"-  AlterBlockItem -> "jammed by an item"-  AlterNothing -> "wasting time on altering nothing"-  PickupOverfull -> "cannot carry any more"-  ProjectAimOnself -> "cannot aim at oneself"-  ProjectBlockTerrain -> "aiming obstructed by terrain"-  ProjectBlockActor -> "aiming blocked by an actor"-  ProjectBlockFoes -> "aiming interrupted by foes"-  ProjectBlind -> "blind actors cannot aim"-  TriggerNothing -> "wasting time on triggering nothing"
Game/LambdaHack/Common/State.hs view
@@ -3,12 +3,11 @@   ( -- * Basic game state, local or global     State     -- * State components-  , sdungeon, sdepth, sactorD, sitemD, sfactionD, stime, scops, shigh+  , sdungeon, stotalDepth, sactorD, sitemD, sfactionD, stime, scops, shigh     -- * State operations   , defStateGlobal, emptyState, localFromGlobal   , updateDungeon, updateDepth, updateActorD, updateItemD-  , updateFaction, updateTime, updateCOps, getLocalTime-  , isSpawnFaction+  , updateFactionD, updateTime, updateCOps   ) where  import Data.Binary@@ -18,32 +17,33 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.HighScore as HighScore+import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.TileKind-import Game.LambdaHack.Utils.Frequency  -- | View on game state. "Remembered" fields carry a subset of the info -- in the client copies of the state. Clients never directly change -- their @State@, but apply atomic actions sent by the server to do so. data State = State-  { _sdungeon  :: !Dungeon      -- ^ remembered dungeon-  , _sdepth    :: !Int          -- ^ dungeon \'depth\' for items creation, etc.-  , _sactorD   :: !ActorDict    -- ^ remembered actors in the dungeon-  , _sitemD    :: !ItemDict     -- ^ remembered items in the dungeon-  , _sfactionD :: !FactionDict  -- ^ remembered sides still in game-  , _stime     :: !Time         -- ^ global game time-  , _scops     :: Kind.COps     -- ^ remembered content-  , _shigh     :: !HighScore.ScoreTable  -- ^ high score table+  { _sdungeon    :: !Dungeon      -- ^ remembered dungeon+  , _stotalDepth :: !AbsDepth     -- ^ absolute dungeon depth, for item creation+  , _sactorD     :: !ActorDict    -- ^ remembered actors in the dungeon+  , _sitemD      :: !ItemDict     -- ^ remembered items in the dungeon+  , _sfactionD   :: !FactionDict  -- ^ remembered sides still in game+  , _stime       :: !Time         -- ^ global game time+  , _scops       :: Kind.COps     -- ^ remembered content+  , _shigh       :: !HighScore.ScoreTable  -- ^ high score table   }   deriving (Show, Eq)  -- TODO: add a flag 'fresh' and when saving levels, don't save -- and when loading regenerate this level.-unknownLevel :: Kind.Ops TileKind -> Int -> X -> Y+unknownLevel :: Kind.Ops TileKind -> AbsDepth -> X -> Y              -> Text -> ([Point], [Point]) -> Int -> Int -> Int -> Bool              -> Level unknownLevel Kind.Ops{ouniqGroup} ldepth lxsize lysize ldesc lstair lclear@@ -61,9 +61,10 @@            , lstair            , lseen = 0            , lclear-           , ltime = timeTurn+           , ltime = timeZero+           , lactorFreq = []            , litemNum = 0-           , litemFreq = toFreq "client item freq" []+           , litemFreq = []            , lsecret            , lhidden            , lescape@@ -80,14 +81,14 @@   in unknownMap PointArray.// outerUpdate  -- | Initial complete global game state.-defStateGlobal :: Dungeon -> Int+defStateGlobal :: Dungeon -> AbsDepth                -> FactionDict -> Kind.COps -> HighScore.ScoreTable                -> State-defStateGlobal _sdungeon _sdepth _sfactionD _scops _shigh =+defStateGlobal _sdungeon _stotalDepth _sfactionD _scops _shigh =   State     { _sactorD = EM.empty     , _sitemD = EM.empty-    , _stime = timeTurn+    , _stime = timeZero     , ..     } @@ -96,11 +97,11 @@ emptyState =   State     { _sdungeon = EM.empty-    , _sdepth = 0+    , _stotalDepth = AbsDepth 0     , _sactorD = EM.empty     , _sitemD = EM.empty     , _sfactionD = EM.empty-    , _stime = timeTurn+    , _stime = timeZero     , _scops = undefined     , _shigh = HighScore.empty     }@@ -126,8 +127,8 @@ updateDungeon f s = s {_sdungeon = f (_sdungeon s)}  -- | Update dungeon depth.-updateDepth :: (Int -> Int) -> State -> State-updateDepth f s = s {_sdepth = f (_sdepth s)}+updateDepth :: (AbsDepth -> AbsDepth) -> State -> State+updateDepth f s = s {_stotalDepth = f (_stotalDepth s)}  -- | Update the actor dictionary. updateActorD :: (ActorDict -> ActorDict) -> State -> State@@ -138,8 +139,8 @@ updateItemD f s = s {_sitemD = f (_sitemD s)}  -- | Update faction data within state.-updateFaction :: (FactionDict -> FactionDict) -> State -> State-updateFaction f s = s {_sfactionD = f (_sfactionD s)}+updateFactionD :: (FactionDict -> FactionDict) -> State -> State+updateFactionD f s = s {_sfactionD = f (_sfactionD s)}  -- | Update global time within state. updateTime :: (Time -> Time) -> State -> State@@ -149,19 +150,11 @@ updateCOps :: (Kind.COps -> Kind.COps) -> State -> State updateCOps f s = s {_scops = f (_scops s)} --- | Get current time from the dungeon data.-getLocalTime :: LevelId -> State -> Time-getLocalTime lid s = ltime $ _sdungeon s EM.! lid---- | Tell whether the faction can spawn actors.-isSpawnFaction :: FactionId -> State -> Bool-isSpawnFaction fid s = isSpawnFact $ _sfactionD s EM.! fid- sdungeon :: State -> Dungeon sdungeon = _sdungeon -sdepth :: State -> Int-sdepth = _sdepth+stotalDepth :: State -> AbsDepth+stotalDepth = _stotalDepth  sactorD :: State -> ActorDict sactorD = _sactorD@@ -184,7 +177,7 @@ instance Binary State where   put State{..} = do     put _sdungeon-    put _sdepth+    put _stotalDepth     put _sactorD     put _sitemD     put _sfactionD@@ -192,7 +185,7 @@     put _shigh   get = do     _sdungeon <- get-    _sdepth <- get+    _stotalDepth <- get     _sactorD <- get     _sitemD <- get     _sfactionD <- get
+ Game/LambdaHack/Common/Thread.hs view
@@ -0,0 +1,26 @@+-- | Keeping track of forked threads.+module Game.LambdaHack.Common.Thread+  ( forkChild, waitForChildren+  ) where++import Control.Concurrent.Async+import Control.Concurrent.MVar++-- Swiped from http://www.haskell.org/ghc/docs/latest/html/libraries/base/Control-Concurrent.html. Ported to Async to link exceptions, to let travis tests fail.++forkChild :: MVar [Async ()] -> IO () -> IO ()+forkChild children io = do+  a <- async io+  link a+  childs <- takeMVar children+  putMVar children (a : childs)++waitForChildren :: MVar [Async ()] -> IO ()+waitForChildren children = do+  cs <- takeMVar children+  case cs of+    [] -> return ()+    m : ms -> do+      putMVar children ms+      wait m+      waitForChildren children
Game/LambdaHack/Common/Tile.hs view
@@ -15,7 +15,7 @@ module Game.LambdaHack.Common.Tile   ( SmellTime   , kindHasFeature, hasFeature-  , isClear, isLit, isWalkable, isPassable, isDoor, isSuspect+  , isClear, isLit, isWalkable, isPassableKind, isPassable, isDoor, isSuspect   , isExplorable, lookSimilar, speedup   , openTo, closeTo, causeEffects, revealAs, hideAs   , isOpenable, isClosable, isChangeable, isEscape, isStair@@ -69,7 +69,8 @@   \k -> Kind.accessTab isWalkableTab k isWalkable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile --- | Whether actors can walk into a tile, perhaps opening a door first.+-- | Whether actors can walk into a tile, perhaps opening a door first,+-- perhaps a hidden door. -- Essential for efficiency of pathfinding, hence tabulated. isPassable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool {-# INLINE isPassable #-}@@ -93,12 +94,23 @@   \k -> Kind.accessTab isSuspectTab k isSuspect cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile --- | Whether a tile can be explored, possibly yielding a treasure.--- Note that non-walkable tiles can hold treasure, e.g., caches.+-- | Whether a tile kind (specified by its id) has a ChangeTo feature.+-- Essential for efficiency of pathfinding, hence tabulated.+isChangeable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool+{-# INLINE isChangeable #-}+isChangeable Kind.Ops{ospeedup = Just Kind.TileSpeedup{isChangeableTab}} =+  \k -> Kind.accessTab isChangeableTab k+isChangeable cotile = assert `failure` "no speedup" `twith` Kind.obounds cotile++-- | Whether one can easily explore a tile, possibly finding a treasure+-- or a clue. Doors can't be explorable since revealing a secret tile+-- should not change it's (walkable and) explorable status.+-- Door status should not depend on whether they are open or not+-- so that a foe opening a door doesn't force us to backtrack to explore it. isExplorable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool {-# INLINE isExplorable #-} isExplorable cotile t =-  isWalkable cotile t || isDoor cotile t || isChangeable cotile t+  (isWalkable cotile t || isClear cotile t) && not (isDoor cotile t)  -- | The player can't tell one tile from the other. lookSimilar :: TileKind -> TileKind -> Bool@@ -120,19 +132,28 @@                                $ kindHasFeature F.Clear       isLitTab = Kind.createTab cotile $ not . kindHasFeature F.Dark       isWalkableTab = Kind.createTab cotile $ kindHasFeature F.Walkable-      isPassableTab = Kind.createTab cotile $ \tk ->-        let getTo F.OpenTo{} = True-            getTo F.Walkable = True-            getTo _ = False-        in any getTo $ tfeature tk+      isPassableTab = Kind.createTab cotile isPassableKind       isDoorTab = Kind.createTab cotile $ \tk ->         let getTo F.OpenTo{} = True             getTo F.CloseTo{} = True             getTo _ = False         in any getTo $ tfeature tk       isSuspectTab = Kind.createTab cotile $ kindHasFeature F.Suspect+      isChangeableTab = Kind.createTab cotile $ \tk ->+        let getTo F.ChangeTo{} = True+            getTo _ = False+        in any getTo $ tfeature tk   in Kind.TileSpeedup {..} +isPassableKind :: TileKind -> Bool+isPassableKind tk =+  let getTo F.Walkable = True+      getTo F.OpenTo{} = True+      getTo F.ChangeTo{} = True  -- can change to passable and may have loot+      getTo F.Suspect = True+      getTo _ = False+  in any getTo $ tfeature tk+ openTo :: Kind.Ops TileKind -> Kind.Id TileKind -> Rnd (Kind.Id TileKind) openTo Kind.Ops{okind, opick} t = do   let getTo (F.OpenTo group) acc = group : acc@@ -191,13 +212,6 @@ isClosable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool isClosable Kind.Ops{okind} t =   let getTo F.CloseTo{} = True-      getTo _ = False-  in any getTo $ tfeature $ okind t---- | Whether a tile kind (specified by its id) has a ChangeTo feature.-isChangeable :: Kind.Ops TileKind -> Kind.Id TileKind -> Bool-isChangeable Kind.Ops{okind} t =-  let getTo F.ChangeTo{} = True       getTo _ = False   in any getTo $ tfeature $ okind t
Game/LambdaHack/Common/Time.hs view
@@ -1,11 +1,13 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-} -- | Game time and speed. module Game.LambdaHack.Common.Time-  ( Time, timeZero, timeClip, timeTurn-  , timeAdd, timeFit, timeNegate, timeScale, timeEpsilon-  , timeToDigit-  , Speed, toSpeed, speedZero, speedNormal, speedScale, speedAdd, speedNegate-  , ticksPerMeter, speedFromWeight, rangeFromSpeed+  ( Time, timeZero, timeClip, timeTurn, timeEpsilon+  , absoluteTimeAdd, absoluteTimeNegate, timeFit, timeFitUp+  , Delta(..), timeShift, timeDeltaToFrom, timeDeltaReverse, timeDeltaScale+  , timeDeltaToDigit, ticksPerMeter+  , Speed, toSpeed, fromSpeed, speedZero, speedNormal+  , speedScale, speedAdd, speedNegate+  , speedFromWeight, rangeFromSpeed, rangeFromSpeedAndLinger   ) where  import Data.Binary@@ -18,11 +20,12 @@ -- One tick is 1 microsecond (one millionth of a second), -- one turn is 0.5 s. newtype Time = Time Int64-  deriving (Show, Eq, Ord, Enum)+  deriving (Show, Eq, Ord, Enum, Bounded, Binary) -instance Binary Time where-  put (Time n) = put n-  get = fmap Time get+-- | One-dimentional vectors. Introduced to tell apart the 2 uses of Time:+-- as an absolute game time and as an increment.+newtype Delta a = Delta a+  deriving (Show, Eq, Ord, Enum, Bounded, Binary, Functor)  -- | Start of the game time, or zero lenght time interval. timeZero :: Time@@ -64,28 +67,47 @@   let Time ticksInTurn = timeTurn   in ticksInTurn * turnsInSecond --- | Time addition.-timeAdd :: Time -> Time -> Time-timeAdd (Time t1) (Time t2) = Time (t1 + t2)+-- | Absolute time addition, e.g., for summing the total game session time+-- from the times of individual games.+absoluteTimeAdd :: Time -> Time -> Time+absoluteTimeAdd (Time t1) (Time t2) = Time (t1 + t2) +-- | Shifting an absolute time by a time vector.+timeShift :: Time -> Delta Time -> Time+timeShift (Time t1) (Delta (Time t2)) = Time (t1 + t2)+ -- | How many time intervals of the latter kind fits in an interval -- of the former kind. timeFit :: Time -> Time -> Int timeFit (Time t1) (Time t2) = fromIntegral $ t1 `div` t2 --- | Negate a time interval. Can be used to subtract from a time--- or to reverse the ordering on time.-timeNegate :: Time -> Time-timeNegate (Time t) = Time (-t)+-- | How many time intervals of the latter kind cover an interval+-- of the former kind (rounded up).+timeFitUp :: Time -> Time -> Int+timeFitUp (Time t1) (Time t2) = fromIntegral $ t1 `divUp` t2 --- | Scale time by an @Int@ scalar value.-timeScale :: Time -> Int -> Time-timeScale (Time t) s = Time (t * fromIntegral s)+-- | Reverse a time vector.+timeDeltaReverse :: Delta Time -> Delta Time+timeDeltaReverse (Delta (Time t)) = Delta (Time (-t)) +-- | Absolute time negation. To be used for reversing time flow,+-- e.g., for comparing absolute times in the reverse order.+absoluteTimeNegate :: Time -> Time+absoluteTimeNegate (Time t) = Time (-t)++-- | Time time vector between the second and the first absolute times.+-- The arguments are in the same order as in the underlying scalar subtraction.+timeDeltaToFrom :: Time -> Time -> Delta Time+timeDeltaToFrom (Time t1) (Time t2) = Delta $ Time (t1 - t2)++-- | Scale the time vector by an @Int@ scalar value.+timeDeltaScale :: Delta Time -> Int -> Delta Time+timeDeltaScale (Delta (Time t)) s = Delta (Time (t * fromIntegral s))+ -- | Represent the main 10 thresholds of a time range by digits, -- given the total length of the time range.-timeToDigit :: Time -> Time -> Char-timeToDigit (Time maxT) (Time t) =+timeDeltaToDigit :: Delta Time -> Delta Time -> Char+timeDeltaToDigit (Delta (Time maxT)) (Delta (Time t)) =   let k = 10 * t `div` maxT       digit | k > 9     = '*'             | k < 0     = '-'@@ -96,20 +118,23 @@ -- Actors at normal speed (2 m/s) take one time turn (0.5 s) -- to move one tile (1 m by 1 m). newtype Speed = Speed Int64-  deriving (Show, Eq, Ord)+  deriving (Eq, Ord, Binary) -instance Binary Speed where-  put (Speed n) = put n-  get = fmap Speed get+instance Show Speed where+  show s = show $ fromSpeed s  -- | Number of seconds in a mega-second. sInMs :: Int64 sInMs = 1000000  -- | Constructor for content definitions.-toSpeed :: Double -> Speed-toSpeed s = Speed $ round $ s * fromIntegral sInMs+toSpeed :: Int -> Speed+toSpeed s = Speed $ fromIntegral s * sInMs `div` 10 +-- | Pretty-printing of speed in the format used in content definitions.+fromSpeed :: Speed -> Int+fromSpeed (Speed s) = fromIntegral $ s * 10 `div` sInMs+ -- | No movement possible at that speed. speedZero :: Speed speedZero = Speed 0@@ -131,29 +156,41 @@ speedNegate (Speed n) = Speed (-n)  -- | The number of time ticks it takes to walk 1 meter at the given speed.-ticksPerMeter :: Speed -> Time-ticksPerMeter (Speed v) = Time $ _ticksInSecond * sInMs `divUp` v+ticksPerMeter :: Speed -> Delta Time+ticksPerMeter (Speed v) = Delta $ Time $ _ticksInSecond * sInMs `divUp` max 1 v  -- | Calculate projectile speed from item weight in grams--- and speed bonus in percents.--- See <https://github.com/kosmikus/LambdaHack/wiki/Item-statistics>.+-- and velocity percent modifier.+-- See <https://github.com/LambdaHack/LambdaHack/wiki/Item-statistics>. speedFromWeight :: Int -> Int -> Speed-speedFromWeight weight bonus =+speedFromWeight weight velocityPercent =   let w = fromIntegral weight-      b = fromIntegral bonus+      vp = fromIntegral velocityPercent       mpMs | w <= 500 = sInMs * 16            | w > 500 && w <= 2000 = sInMs * 16 * 1500 `div` (w + 1000)-           | otherwise = sInMs * (10000 - w) `div` 1000-  in Speed $ max 1 $ mpMs * (100 + b) `div` 100+           | w < 16000 = sInMs * (18000 - w) `div` 1000+           | w < 200000 = sInMs  -- half a step per turn is the minimum+           | otherwise = 0  -- unless _very_ heavy+               -- TODO: such high weight should also affect moving+      v = mpMs * vp `div` 100+      -- 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 == 0 then 0 else sInMs+  in Speed $ max minimumSpeed multiple2M  -- | Calculate maximum range in meters of a projectile from its speed.--- See <https://github.com/kosmikus/LambdaHack/wiki/Item-statistics>.+-- See <https://github.com/LambdaHack/LambdaHack/wiki/Item-statistics>. -- With this formula, each projectile flies for at most 1 second, -- that is 2 turns, and then drops to the ground.--- We round down to the nearest multiple of 2 (unless the speed--- is very low), to ensure both turns of flight cover the same distance. rangeFromSpeed :: Speed -> Int-rangeFromSpeed (Speed v) =-  fromIntegral $ if v >= 2 * sInMs-                 then 2 * (v `div` (2 * sInMs))-                 else v `div` sInMs+rangeFromSpeed (Speed v) = fromIntegral $ v `div` sInMs++-- | Calculate maximum range taking into account the linger percentage.+rangeFromSpeedAndLinger :: Speed -> Int -> Int+rangeFromSpeedAndLinger speed linger =+  let range = rangeFromSpeed speed+  in linger * range `div` 100
Game/LambdaHack/Common/Vector.hs view
@@ -3,26 +3,20 @@ -- but not unique, way. module Game.LambdaHack.Common.Vector   ( Vector(..), isUnit, isDiagonal, neg, chessDistVector, euclidDistSqVector-  , moves, compassText, vicinity, vicinityCardinal-  , shift, shiftBounded, trajectoryToPath, displacement, pathToTrajectory+  , moves, movesCardinal, movesDiagonal, compassText, vicinity, vicinityCardinal+  , shift, shiftBounded, trajectoryToPath, trajectoryToPathBounded+  , vectorToFrom, pathToTrajectory   , RadianAngle, rotate, towards-  , BfsDistance, MoveLegal(..), apartBfs-  , fillBfs, findPathBfs, accessBfs, posAimsPos   ) where -import Control.Arrow (second) import Control.Exception.Assert.Sugar import Data.Binary-import Data.Bits (Bits, complement, (.&.), (.|.)) import qualified Data.EnumMap.Strict as EM import Data.Int (Int32)-import Data.List import Data.Maybe-import qualified Data.Sequence as Seq import Data.Text (Text)  import Game.LambdaHack.Common.Point-import qualified Game.LambdaHack.Common.PointArray as PointArray  -- | 2D vectors in cartesian representation. Coordinates grow to the right -- and down, so that the (1, 1) vector points to the bottom-right corner@@ -110,6 +104,10 @@ movesCardinal :: [Vector] movesCardinal = map (uncurry Vector) [(0, -1), (1, 0), (0, 1), (-1, 0)] +-- | Vectors of all diagonal direction unit moves, clockwise, starting north.+movesDiagonal :: [Vector]+movesDiagonal = map (uncurry Vector) [(-1, -1), (1, -1), (1, 1), (-1, 1)]+ -- | All (8 at most) closest neighbours of a point within an area. vicinity :: X -> Y   -- ^ limit the search to this area          -> Point    -- ^ position to find neighbours of@@ -144,20 +142,28 @@ trajectoryToPath :: Point -> [Vector] -> [Point] trajectoryToPath _ [] = [] trajectoryToPath start (v : vs) = let next = shift start v-                           in next : trajectoryToPath next vs+                                  in next : trajectoryToPath next vs --- | A vector from a point to another. We have+-- | A list of points that a list of vectors leads to, bounded by level size.+trajectoryToPathBounded :: X -> Y -> Point -> [Vector] -> [Point]+trajectoryToPathBounded _ _ _ [] = []+trajectoryToPathBounded lxsize lysize start (v : vs) =+  let next = shiftBounded lxsize lysize start v+  in next : trajectoryToPathBounded lxsize lysize next vs++-- | The vector between the second point and the first. We have ----- > shift pos1 (displacement pos1 pos2) == pos2-displacement :: Point -> Point -> Vector-{-# INLINE displacement #-}-displacement (Point x0 y0) (Point x1 y1) = Vector (x1 - x0) (y1 - y0)+-- > shift pos1 (pos2 `vectorToFrom` pos1) == pos2+--+-- The arguments are in the same order as in the underlying scalar subtraction.+vectorToFrom :: Point -> Point -> Vector+{-# INLINE vectorToFrom #-}+vectorToFrom (Point x0 y0) (Point x1 y1) = Vector (x0 - x1) (y0 - y1)  -- | A list of vectors between a list of points. pathToTrajectory :: [Point] -> [Vector] pathToTrajectory [] = []-pathToTrajectory lp1@(_ : lp2) = zipWith displacement lp1 lp2-+pathToTrajectory lp1@(_ : lp2) = zipWith vectorToFrom lp2 lp1 type RadianAngle = Double  -- | Rotate a vector by the given angle (expressed in radians)@@ -215,127 +221,4 @@ towards :: Point -> Point -> Vector towards pos0 pos1 =   assert (pos0 /= pos1 `blame` "towards self" `twith` (pos0, pos1))-  $ normalizeVector $ displacement pos0 pos1--newtype BfsDistance = BfsDistance Word8-  deriving (Show, Eq, Ord, Enum, Bounded, Bits)--data MoveLegal = MoveBlocked | MoveToOpen | MoveToUnknown-  deriving Eq--minKnownBfs :: BfsDistance-minKnownBfs = toEnum $ (1 + fromEnum (maxBound :: BfsDistance)) `div` 2--apartBfs :: BfsDistance-apartBfs = pred minKnownBfs---- TODO: Move somewhere; in particular, only clients need to know that.-fillBfs :: (Point -> Point -> MoveLegal)  -- ^ is move from a known tile legal-        -> (Point -> Point -> Bool)       -- ^ is a move from unknown legal-        -> Point                          -- ^ starting position-        -> PointArray.Array BfsDistance   -- ^ initial array, with @apartBfs@-        -> PointArray.Array BfsDistance   -- ^ array with calculated distances-fillBfs isEnterable passUnknown origin aInitial =-  -- TODO: copy, thaw, mutate, freeze-  let maxUnknownBfs = pred apartBfs-      maxKnownBfs = pred maxBound-      bfs :: Seq.Seq (Point, BfsDistance)-          -> PointArray.Array BfsDistance-          -> PointArray.Array BfsDistance-      bfs q a =-        case Seq.viewr q of-          Seq.EmptyR -> a  -- no more positions to check-          _ Seq.:> (_, d)-            | d == maxUnknownBfs || d == maxKnownBfs -> a  -- too far-          q1 Seq.:> (pos, oldDistance) | oldDistance >= minKnownBfs ->-            let distance = succ oldDistance-                allMvs = map (shift pos) moves-                freshMv p = a PointArray.! p == apartBfs-                freshMvs = filter freshMv allMvs-                legal p = (p, isEnterable pos p)-                legalities = map legal freshMvs-                notBlocked = filter ((/= MoveBlocked) . snd) legalities-                legalToDist l = if l == MoveToOpen-                                then distance-                                else distance .&. complement minKnownBfs-                mvs = map (second legalToDist) notBlocked-                q2 = foldr (Seq.<|) q1 mvs-                s2 = a PointArray.// mvs-            in bfs q2 s2-          q1 Seq.:> (pos, oldDistance) ->-            let distance = succ oldDistance-                allMvs = map (shift pos) moves-                goodMv p = a PointArray.! p == apartBfs && passUnknown pos p-                mvs = zip (filter goodMv allMvs) (repeat distance)-                q2 = foldr (Seq.<|) q1 mvs-                s2 = a PointArray.// mvs-            in bfs q2 s2-      origin0 = (origin, minKnownBfs)-  in bfs (Seq.singleton origin0) (aInitial PointArray.// [origin0])---- TODO: Use http://harablog.wordpress.com/2011/09/07/jump-point-search/--- to determine a few really different paths and compare them,--- e.g., how many closed doors they pass, open doors, unknown tiles--- on the path or close enough to reveal them.--- Also, check if JPS can somehow optimize BFS or pathBfs.--- | Find a path, without the source position, with the smallest length.--- The @eps@ coefficient determines which direction (or the closest--- directions available) that path should prefer, where 0 means north-west--- and 1 means north.-findPathBfs :: (Point -> Point -> MoveLegal)-            -> (Point -> Point -> Bool)-            -> Point -> Point -> Int -> PointArray.Array BfsDistance-            -> Maybe [Point]-findPathBfs isEnterable passUnknown source target sepsRaw bfs =-  assert (bfs PointArray.! source == minKnownBfs) $-  let targetDist = bfs PointArray.! target-  in if targetDist == apartBfs-     then Nothing-     else-       let eps = abs sepsRaw `mod` length moves-           mix (x : xs) ys = x : mix ys xs-           mix [] ys = ys-           preferedMoves = let (ch1, ch2) = splitAt eps moves-                               ch = ch2 ++ ch1-                           in mix ch (reverse ch)-           track :: Point -> BfsDistance -> [Point] -> [Point]-           track pos oldDist suffix | oldDist == minKnownBfs =-             assert (pos == source-                     `blame` (source, target, pos, suffix)) suffix-           track pos oldDist suffix | oldDist > minKnownBfs =-             let dist = pred oldDist-                 children = map (shift pos) preferedMoves-                 matchesDist p = bfs PointArray.! p == dist-                                 && isEnterable p pos == MoveToOpen-                 minP = fromMaybe (assert `failure` (pos, oldDist, children))-                                  (find matchesDist children)-             in track minP dist (pos : suffix)-           track pos oldDist suffix =-             let distUnknown = pred oldDist-                 distKnown = distUnknown .|. minKnownBfs-                 children = map (shift pos) preferedMoves-                 matchesDistUnknown p = bfs PointArray.! p == distUnknown-                                        && passUnknown p pos-                 matchesDistKnown p = bfs PointArray.! p == distKnown-                                      && isEnterable p pos == MoveToUnknown-                 (minP, dist) = case find matchesDistKnown children of-                   Just p -> (p, distKnown)-                   Nothing -> case find matchesDistUnknown children of-                     Just p -> (p, distUnknown)-                     Nothing -> assert `failure` (pos, oldDist, children)-             in track minP dist (pos : suffix)-       in Just $ track target targetDist []--accessBfs :: PointArray.Array BfsDistance -> Point -> Maybe Int-{-# INLINE accessBfs #-}-accessBfs bfs target =-  let dist = bfs PointArray.! target-  in if dist == apartBfs-     then Nothing-     else Just $ fromEnum $ dist .&. complement minKnownBfs--posAimsPos :: PointArray.Array BfsDistance -> Point -> Point -> Bool-{-# INLINE posAimsPos #-}-posAimsPos bfs bpos target =-  let mdist = accessBfs bfs target-  in mdist == Just (chessDist bpos target)+  $ normalizeVector $ pos1 `vectorToFrom` pos0
− Game/LambdaHack/Content/ActorKind.hs 
@@ -1,47 +0,0 @@--- | The type of kinds of monsters and heroes.-module Game.LambdaHack.Content.ActorKind-  ( ActorKind(..), validateActorKind-  ) where--import Control.Arrow ((&&&))-import Data.List-import qualified Data.Ord as Ord-import Data.Text (Text)-import qualified Data.Text as T--import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.Misc-import qualified Game.LambdaHack.Common.Random as Random-import Game.LambdaHack.Common.Time---- TODO: make all but a few fields optional in some way, so that, a.g.,--- a game content with no regeneration does not ever need to mention aregen.--- | Actor properties that are fixed for a given kind of actors.-data ActorKind = ActorKind-  { asymbol :: !Char             -- ^ map symbol-  , aname   :: !Text             -- ^ short description-  , afreq   :: !Freqs            -- ^ frequency within groups-  , acolor  :: !Color            -- ^ map color-  , aspeed  :: !Speed            -- ^ natural speed in m/s-  , ahp     :: !Random.RollDice  -- ^ encodes initial and maximal hp-  , asight  :: !Bool             -- ^ can it see?-  , asmell  :: !Bool             -- ^ can it smell?-  , aiq     :: !Int              -- ^ intelligence-  , aregen  :: !Int              -- ^ number of turns to regenerate 1 HP-  , acanDo  :: ![Ability]        -- ^ the set of supported abilities-  }-  deriving Show  -- No Eq and Ord to make extending it logically sound, see #53---- | Filter a list of kinds, passing through only the incorrect ones, if any.------ Make sure actor kinds can be told apart on the level map.-validateActorKind :: [ActorKind] -> [ActorKind]-validateActorKind l =-  let cmp = Ord.comparing $ asymbol &&& acolor-      eq ka1 ka2 = cmp ka1 ka2 == Ord.EQ-      sorted = sortBy cmp l-      nubbed = nubBy eq sorted-      tooSimilar = deleteFirstsBy eq sorted nubbed-      tooVerbose = filter (\ak -> T.length (aname ak) > 25) l-  in tooSimilar ++ tooVerbose
Game/LambdaHack/Content/CaveKind.hs view
@@ -6,37 +6,41 @@ import Data.Text (Text) import qualified Data.Text as T +import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random  -- | Parameters for the generation of dungeon levels. data CaveKind = CaveKind-  { csymbol         :: !Char        -- ^ a symbol-  , cname           :: !Text        -- ^ short description-  , cfreq           :: !Freqs       -- ^ frequency within groups-  , cxsize          :: !X           -- ^ X size of the whole cave-  , cysize          :: !Y           -- ^ Y size of the whole cave-  , cgrid           :: !RollDiceXY  -- ^ the dimensions of the grid of places-  , cminPlaceSize   :: !RollDiceXY  -- ^ minimal size of places-  , cmaxPlaceSize   :: !RollDiceXY  -- ^ maximal size of places-  , cdarkChance     :: !RollDeep    -- ^ the chance a place is dark-  , cnightChance    :: !RollDeep    -- ^ the chance the cave is dark-  , cauxConnects    :: !Rational    -- ^ a proportion of extra connections-  , cmaxVoid        :: !Rational    -- ^ at most this proportion of rooms void-  , cminStairDist   :: !Int         -- ^ minimal distance between stairs-  , cdoorChance     :: !Chance      -- ^ the chance of a door in an opening-  , copenChance     :: !Chance      -- ^ if there's a door, is it open?-  , chidden         :: !Int         -- ^ if not open, hidden one in n times-  , citemNum        :: !RollDice    -- ^ the number of items in the cave-  , citemFreq       :: ![(Int, Text)]  -- ^ item groups to consider-  , cdefTile        :: !Text        -- ^ the default cave tile group name-  , cdarkCorTile    :: !Text        -- ^ the dark cave corridor tile group name-  , clitCorTile     :: !Text        -- ^ the lit cave corridor tile group name-  , cfillerTile     :: !Text        -- ^ the filler wall group name-  , couterFenceTile :: !Text        -- ^ the outer fence wall group name-  , clegendDarkTile :: !Text        -- ^ the dark place plan legend group name-  , clegendLitTile  :: !Text        -- ^ the lit place plan legend group name+  { csymbol         :: !Char         -- ^ a symbol+  , cname           :: !Text         -- ^ short description+  , cfreq           :: !Freqs        -- ^ frequency within groups+  , cxsize          :: !X            -- ^ X size of the whole cave+  , cysize          :: !Y            -- ^ Y size of the whole cave+  , cgrid           :: !Dice.DiceXY  -- ^ the dimensions of the grid of places+  , cminPlaceSize   :: !Dice.DiceXY  -- ^ minimal size of places+  , cmaxPlaceSize   :: !Dice.DiceXY  -- ^ maximal size of places+  , cdarkChance     :: !Dice.Dice    -- ^ the chance a place is dark+  , cnightChance    :: !Dice.Dice    -- ^ the chance the cave is dark+  , cauxConnects    :: !Rational     -- ^ a proportion of extra connections+  , cmaxVoid        :: !Rational     -- ^ at most this proportion of rooms void+  , cminStairDist   :: !Int          -- ^ minimal distance between stairs+  , cdoorChance     :: !Chance       -- ^ the chance of a door in an opening+  , copenChance     :: !Chance       -- ^ if there's a door, is it open?+  , chidden         :: !Int          -- ^ if not open, hidden one in n times+  , cactorFreq      :: !Freqs        -- ^ actor groups to consider+  , citemNum        :: !Dice.Dice    -- ^ the number of items in the cave+  , citemFreq       :: !Freqs        -- ^ item groups to consider+  , cplaceFreq      :: !Freqs        -- ^ place groups to consider+  , cpassable       :: !Bool         -- ^ are passable default tiles permitted+  , cdefTile        :: !Text         -- ^ the default cave tile group name+  , cdarkCorTile    :: !Text         -- ^ the dark cave corridor tile group name+  , clitCorTile     :: !Text         -- ^ the lit cave corridor tile group name+  , cfillerTile     :: !Text         -- ^ the filler wall group name+  , couterFenceTile :: !Text         -- ^ the outer fence wall group name+  , clegendDarkTile :: !Text         -- ^ the dark place plan legend group name+  , clegendLitTile  :: !Text         -- ^ the lit place plan legend group name   }   deriving Show  -- No Eq and Ord to make extending it logically sound, see #53 @@ -46,11 +50,11 @@ -- Catch caves with not enough space for all the places. Check the size -- of the cave descriptions to make sure they fit on screen. validateCaveKind :: [CaveKind] -> [CaveKind]-validateCaveKind = filter (\ CaveKind{..} ->-  let (maxGridX, maxGridY) = maxDiceXY cgrid-      (minMinSizeX, minMinSizeY) = minDiceXY cminPlaceSize-      (maxMinSizeX, maxMinSizeY) = maxDiceXY cminPlaceSize-      (minMaxSizeX, minMaxSizeY) = minDiceXY cmaxPlaceSize+validateCaveKind = filter (\CaveKind{..} ->+  let (maxGridX, maxGridY) = Dice.maxDiceXY cgrid+      (minMinSizeX, minMinSizeY) = Dice.minDiceXY cminPlaceSize+      (maxMinSizeX, maxMinSizeY) = Dice.maxDiceXY cminPlaceSize+      (minMaxSizeX, minMaxSizeY) = Dice.minDiceXY cmaxPlaceSize       -- If there is at most one room, we need extra borders for a passage,       -- but if there may be more rooms, we have that space, anyway,       -- because multiple rooms take more space than borders.
Game/LambdaHack/Content/FactionKind.hs view
@@ -9,11 +9,11 @@  -- | Faction properties that are fixed for a given kind of factions. data FactionKind = FactionKind-  { fsymbol        :: !Char       -- ^ a symbol-  , fname          :: !Text       -- ^ short description-  , ffreq          :: !Freqs      -- ^ frequency within groups-  , fAbilityLeader :: ![Ability]  -- ^ abilities of the picked leader-  , fAbilityOther  :: ![Ability]  -- ^ abilities of the other actors+  { fsymbol       :: !Char    -- ^ a symbol+  , fname         :: !Text    -- ^ short description+  , ffreq         :: !Freqs   -- ^ frequency within groups+  , fSkillsLeader :: !Skills  -- ^ skills of the picked leader+  , fSkillsOther  :: !Skills  -- ^ skills of the other actors   }   deriving Show
Game/LambdaHack/Content/ItemKind.hs view
@@ -1,33 +1,55 @@--- | The type of kinds of weapons and treasure.+-- | The type of kinds of weapons, treasure, organs, shrapnel and actors. module Game.LambdaHack.Content.ItemKind-  ( ItemKind(..), validateItemKind+  ( ItemKind(..), toVelocity, toLinger, validateItemKind   ) where +import Data.Function+import Data.List+import Data.Ord import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU +import qualified Game.LambdaHack.Common.Dice as Dice+import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Flavour-import qualified Game.LambdaHack.Common.ItemFeature as IF import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Random  -- | Item properties that are fixed for a given kind of items. data ItemKind = ItemKind-  { isymbol      :: !Char          -- ^ map symbol-  , iname        :: !Text          -- ^ generic name-  , ifreq        :: !Freqs         -- ^ frequency within groups-  , iflavour     :: ![Flavour]     -- ^ possible flavours-  , icount       :: !RollDeep      -- ^ created in that quantify-  , iverbApply   :: !MU.Part       -- ^ the verb for applying and combat-  , iverbProject :: !MU.Part       -- ^ the verb for projecting-  , iweight      :: !Int           -- ^ weight in grams-  , itoThrow     :: !Int           -- ^ percentage bonus to throw speed-  , ifeature     :: ![IF.Feature]  -- ^ properties+  { isymbol  :: !Char              -- ^ map symbol+  , iname    :: !Text              -- ^ generic name+  , ifreq    :: !Freqs             -- ^ frequency within groups+  , iflavour :: ![Flavour]         -- ^ possible flavours+  , icount   :: !Dice.Dice         -- ^ created in that quantity+  , irarity  :: ![(Int, Int)]      -- ^ rarity on given depths+  , iverbHit :: !MU.Part           -- ^ the verb for applying and melee+  , iweight  :: !Int               -- ^ weight in grams+  , iaspects :: ![Effect.Aspect Dice.Dice]+                                   -- ^ keep the aspect continuously+  , ieffects :: ![Effect.Effect Dice.Dice]+                                   -- ^ cause the effect when triggered+  , ifeature :: ![Effect.Feature]  -- ^ public properties+  , idesc    :: !Text              -- ^ description+  , ikit     :: ![(Text, CStore)]  -- ^ accompanying organs and items   }   deriving Show  -- No Eq and Ord to make extending it logically sound, see #53 --- | No specific possible problems for the content of this kind, so far,--- so the validation function always returns the empty list of offending kinds.+toVelocity :: Int -> Effect.Feature+toVelocity n = Effect.ToThrow $ Effect.ThrowMod n 100++toLinger :: Int -> Effect.Feature+toLinger n = Effect.ToThrow $ Effect.ThrowMod 100 n++-- | Filter a list of kinds, passing through only the incorrect ones, if any. validateItemKind :: [ItemKind] -> [ItemKind]-validateItemKind l = filter (\ik -> T.length (iname ik) > 25) l+validateItemKind l =+  let bad ik = T.length (iname ik) > 23+               || let sortedRarity = sortBy (comparing fst) (irarity ik)+                  in sortedRarity /= irarity ik+                     || nubBy ((==) `on` fst) sortedRarity /= sortedRarity+                     || case (sortedRarity, reverse sortedRarity) of+                       ((lowest, _) : _, (highest, _) : _) ->+                         lowest < 1 || highest > 10+                       _ -> False+  in filter bad l
Game/LambdaHack/Content/ModeKind.hs view
@@ -4,11 +4,11 @@   ) where  import Data.Binary-import qualified Data.EnumMap.Strict as EM+import qualified Data.IntMap.Strict as IM import Data.Text (Text) import qualified NLP.Miniutter.English as MU () -import Game.LambdaHack.Common.Misc (Freqs, LevelId)+import Game.LambdaHack.Common.Misc (Freqs)  -- | Game mode specification. data ModeKind = ModeKind@@ -17,6 +17,7 @@   , mfreq    :: !Freqs    -- ^ frequency within groups   , mplayers :: !Players  -- ^ players taking part in the game   , mcaves   :: !Caves    -- ^ arena of the game+  , mdesc    :: !Text     -- ^ description   }   deriving Show @@ -25,7 +26,7 @@ -- that can randomly appear. The second component of the pair -- is the @Escape@ feature on the level. @True@ means it's represented -- by @<@, @False@, by @>@.-type Caves = EM.EnumMap LevelId (Text, Maybe Bool)+type Caves = IM.IntMap (Text, Maybe Bool)  -- | The specification of players for the game mode. data Players = Players@@ -37,17 +38,17 @@  -- | Properties of a particular player. data Player = Player-  { playerName     :: !Text     -- ^ name of the player-  , playerFaction  :: !Text     -- ^ name of faction(s) the player can control-  , playerSpawn    :: !Int      -- ^ spawning frequency-  , playerEntry    :: !LevelId  -- ^ level where the initial members start-  , playerInitial  :: !Int      -- ^ number of initial members-  , playerAiLeader :: !Bool     -- ^ is the leader under AI control?-  , playerAiOther  :: !Bool     -- ^ are the others under AI control?-  , playerHuman    :: !Bool     -- ^ is the player considered human-                                -- and so, e.g., eligible for a high score?-  , playerUI       :: !Bool     -- ^ does the faction have a UI client-                                -- (for control or passive observation)+  { playerName    :: !Text     -- ^ name of the player+  , playerFaction :: !Text     -- ^ name of faction(s) the player can control+  , playerIsSpawn :: !Bool     -- ^ whether the player is a spawn (score, AI)+  , playerIsHero  :: !Bool     -- ^ whether the player is a hero (score, AI, UI)+  , playerEntry   :: !Int      -- ^ level where the initial members start+  , playerInitial :: !Int      -- ^ number of initial members+  , playerLeader  :: !Bool     -- ^ leaderless factions can't be controlled+                               --   by a human or a user-supplied AI client+  , playerAI      :: !Bool     -- ^ is the faction under AI control?+  , playerUI      :: !Bool     -- ^ does the faction have a UI client+                               --   (for control or passive observation)   }   deriving (Show, Eq) @@ -63,21 +64,21 @@   put Player{..} = do     put playerName     put playerFaction-    put playerSpawn+    put playerIsSpawn+    put playerIsHero     put playerEntry     put playerInitial-    put playerAiLeader-    put playerAiOther-    put playerHuman+    put playerLeader+    put playerAI     put playerUI   get = do     playerName <- get     playerFaction <- get-    playerSpawn <- get+    playerIsSpawn <- get+    playerIsHero <- get     playerEntry <- get     playerInitial <- get-    playerAiLeader <- get-    playerAiOther <- get-    playerHuman <- get+    playerLeader <- get+    playerAI <- get     playerUI <- get     return $! Player{..}
Game/LambdaHack/Content/PlaceKind.hs view
@@ -10,20 +10,24 @@  -- | Parameters for the generation of small areas within a dungeon level. data PlaceKind = PlaceKind-  { psymbol  :: !Char      -- ^ a symbol-  , pname    :: !Text      -- ^ short description-  , pfreq    :: !Freqs     -- ^ frequency within groups-  , pcover   :: !Cover     -- ^ how to fill whole place based on the corner-  , pfence   :: !Fence     -- ^ whether to fence the place with solid border-  , ptopLeft :: ![Text]    -- ^ plan of the top-left corner of the place+  { psymbol   :: !Char      -- ^ a symbol+  , pname     :: !Text      -- ^ short description+  , pfreq     :: !Freqs     -- ^ frequency within groups+  , prarity   :: ![(Int, Int)]  -- ^ rarity on given depths+  , pcover    :: !Cover     -- ^ how to fill whole place based on the corner+  , pfence    :: !Fence     -- ^ whether to fence the place with solid border+  , ptopLeft  :: ![Text]    -- ^ plan of the top-left corner of the place+  , poverride :: ![(Char, Text)]  -- ^ legend override, ignoring tile symbol   }   deriving Show  -- No Eq and Ord to make extending it logically sound, see #53 --- | A method of filling the whole area by transforming a given corner.+-- | A method of filling the whole area (except for CVerbatim, which is just+-- placed in the middle of the area), by transforming a given corner. data Cover =     CAlternate   -- ^ reflect every other corner, overlapping 1 row and column   | CStretch     -- ^ fill symmetrically 4 corners and stretch their borders   | CReflect     -- ^ tile separately and symmetrically quarters of the place+  | CVerbatim    -- ^ just build the given interior, without filling the area   deriving (Show, Eq)  -- | The choice of a fence type for the place.
Game/LambdaHack/Content/RuleKind.hs view
@@ -7,8 +7,6 @@ import Data.Text (Text) import Data.Version -import Game.LambdaHack.Common.HumanCmd-import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point @@ -42,49 +40,28 @@   , raccessibleDoor :: !(Maybe (Point -> Point -> Bool))   , rtitle          :: !Text      -- ^ the title of the game   , rpathsDataFile  :: FilePath -> IO FilePath-                                  -- ^ the path to data files+                                   -- ^ the path to data files   , rpathsVersion   :: !Version   -- ^ the version of the game-  , ritemMelee      :: ![Char]    -- ^ symbols of melee weapons-  , ritemRanged     :: ![Char]    -- ^ ranged weapons and missiles-  , ritemProject    :: ![Char]    -- ^ symbols of items AI can project   , rcfgUIName      :: !FilePath  -- ^ base name of the UI config file   , rcfgUIDefault   :: !String    -- ^ the default UI settings config file   , rmainMenuArt    :: !Text      -- ^ the ASCII art for the Main Menu-  , rhumanCommands  :: ![(K.KM, (CmdCategory, HumanCmd))]-                                  -- ^ default client commands   , rfirstDeathEnds :: !Bool      -- ^ whether first non-spawner actor death-                                  --   ends the game+                                   --   ends the game   , rfovMode        :: !FovMode   -- ^ FOV calculation mode   , rsaveBkpClips   :: !Int       -- ^ game backup is saved that often-  , rleadLevelClips :: !Int       -- ^ AI/spawn leader level flipped that often+  , rleadLevelClips :: !Int       -- ^ flip AI/spawn 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   } --- TODO: should Blind really be a FovMode, or a modifier? Let's decide--- when other similar modifiers are added. -- | Field Of View scanning mode. data FovMode =-    Shadow        -- ^ restrictive shadow casting-  | Permissive    -- ^ permissive FOV-  | Digital !Int  -- ^ digital FOV with the given radius-  | Blind         -- ^ only feeling out adjacent tiles by touch+    Shadow      -- ^ restrictive shadow casting+  | Permissive  -- ^ permissive FOV+  | Digital     -- ^ digital FOV   deriving (Show, Read) -instance Binary FovMode where-  put Shadow      = putWord8 0-  put Permissive  = putWord8 1-  put (Digital r) = putWord8 2 >> put r-  put Blind       = putWord8 3-  get = do-    tag <- getWord8-    case tag of-      0 -> return Shadow-      1 -> return Permissive-      2 -> fmap Digital get-      3 -> return Blind-      _ -> fail "no parse (FovMode)"- -- | A dummy instance of the 'Show' class, to satisfy general requirments -- about content. We won't have many rule sets and they contain functions, -- so defining a proper instance is not practical.@@ -94,3 +71,15 @@ -- | Validates the ASCII art format (TODO). validateRuleKind :: [RuleKind] -> [RuleKind] validateRuleKind _ = []++instance Binary FovMode where+  put Shadow      = putWord8 0+  put Permissive  = putWord8 1+  put Digital     = putWord8 2+  get = do+    tag <- getWord8+    case tag of+      0 -> return Shadow+      1 -> return Permissive+      2 -> return Digital+      _ -> fail "no parse (FovMode)"
Game/LambdaHack/Content/TileKind.hs view
@@ -4,9 +4,10 @@   ) where  import Control.Exception.Assert.Sugar+import Data.Hashable (hash)+import qualified Data.IntSet as IS import qualified Data.Map.Strict as M import Data.Maybe-import qualified Data.Set as S import Data.Text (Text)  import Game.LambdaHack.Common.Color@@ -38,30 +39,32 @@ -- differ wrt dungeon generation, AI preferences, etc. validateTileKind :: [TileKind] -> [TileKind] validateTileKind lt =-  let listFov f = map (\kt -> ( ( tsymbol kt+  let listVis f = map (\kt -> ( ( tsymbol kt                                   , F.Suspect `elem` tfeature kt                                   , f kt                                   )                                 , [kt] )) lt-      mapFov :: (TileKind -> Color) -> M.Map (Char, Bool, Color) [TileKind]-      mapFov f = M.fromListWith (++) $ listFov f+      mapVis :: (TileKind -> Color) -> M.Map (Char, Bool, Color) [TileKind]+      mapVis f = M.fromListWith (++) $ listVis f       namesUnequal [] = assert `failure` "no TileKind content" `twith` lt       namesUnequal (hd : tl) =         -- Catch if at least one is different.         any (/= tname hd) (map tname tl)+        -- TODO: calculate actionFeatures only once for each tile kind         || any (/= actionFeatures True hd) (map (actionFeatures True) tl)-      confusions f = filter namesUnequal $ M.elems $ mapFov f+      confusions f = filter namesUnequal $ M.elems $ mapVis f   in case confusions tcolor ++ confusions tcolor2 of     [] -> []     l : _ -> l  -- | Features of tiles that differentiate them substantially from one another.--- By tile contents validation condition, this means the player+-- By tile content validation condition, this means the player -- can tell such tile apart, and only looking at the map, not tile name. -- So if running uses this function, it won't stop at places that the player -- can't himself tell from other places, and so running does not confer--- any advantages, except UI convenience.-actionFeatures :: Bool -> TileKind -> S.Set F.Feature+-- any advantages, except UI convenience. Hashes are accurate enough+-- for our purpose, given that we use arbitrary heuristics anyway.+actionFeatures :: Bool -> TileKind -> IS.IntSet actionFeatures markSuspect t =   let f feat = case feat of         F.Cause{} -> Just feat@@ -77,6 +80,8 @@         F.HideAs{} -> Nothing         F.RevealAs{} -> Nothing         F.Dark -> Nothing  -- not important any longer, after FOV computed-        F.CanItem -> Nothing-        F.CanActor -> Nothing-  in S.fromList $ mapMaybe f $ tfeature t+        F.OftenItem -> Nothing+        F.OftenActor -> Nothing+        F.NoItem -> Nothing+        F.NoActor -> Nothing+  in IS.fromList $ map hash $ mapMaybe f $ tfeature t
− Game/LambdaHack/Frontend.hs 
@@ -1,233 +0,0 @@--- | Display game data on the screen and receive user input--- using one of the available raw frontends and derived  operations.-module Game.LambdaHack.Frontend-  ( -- * Re-exported part of the raw frontend-    frontendName-    -- * Derived operation-  , startupF-    -- * Connection channels-  , ChanFrontend, FrontReq(..), ConnMulti(..), connMulti-  ) where--import Control.Concurrent-import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, writeTQueue)-import qualified Control.Concurrent.STM as STM-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import System.IO-import System.IO.Unsafe (unsafePerformIO)--import Game.LambdaHack.Common.Animation-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Key as K-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Frontend.Chosen-import Game.LambdaHack.Utils.LQueue-import Game.LambdaHack.Utils.Thread--type ChanFrontend = TQueue K.KM---- | The first component is the number of UI players at game start.-type FromMulti = MVar (Int, FactionId -> (ChanFrontend, Text))--type ToMulti = TQueue (FactionId, FrontReq)--data FrontReq =-    FrontFrame {frontAc :: !AcFrame}-      -- ^ show a frame, if the fid acitve, or save it to the client's queue-  | FrontKey {frontKM :: ![K.KM], frontFr :: !SingleFrame}-      -- ^ flush frames, possibly show fadeout/fadein and ask for a keypress-  | FrontSlides {frontClear :: ![K.KM], frontSlides :: ![SingleFrame]}-      -- ^ show a whole slideshow without interleaving with other clients-  | FrontFinish-      -- ^ exit frontend loop--type ReqMap = EM.EnumMap FactionId (LQueue AcFrame)---- | Multiplex connection channels, for the case of a frontend shared--- among clients. This is transparent to the clients themselves.-data ConnMulti = ConnMulti-  { fromMulti :: !FromMulti-  , toMulti   :: !ToMulti-  }--startupF :: DebugModeCli -> IO () -> IO ()-startupF dbg cont =-  (if sfrontendNo dbg then noStartup-   else if sfrontendStd dbg then stdStartup-        else chosenStartup) dbg $ \fs -> do-    let debugPrint t = when (sdbgMsgCli dbg) $ do-          T.hPutStrLn stderr t-          hFlush stderr-    children <- newMVar []-    void $ forkChild children $ loopFrontend fs connMulti-    cont-    debugPrint "Server shuts down"-    let toF = toMulti connMulti-    -- TODO: instead of this, wait for clients to send FrontFinish or timeout-    atomically $ writeTQueue toF (toEnum 0 {-hack-}, FrontFinish)-    waitForChildren children-    debugPrint "Frontend shuts down"---- | Display a prompt, wait for any of the specified keys (for any key,--- if the list is empty). Repeat if an unexpected key received.-promptGetKey :: Frontend -> [K.KM] -> SingleFrame -> IO K.KM-promptGetKey fs [] frame = fpromptGetKey fs frame-promptGetKey fs keys@(firstKM:_) frame = do-  km <- fpromptGetKey fs frame-  if km `elem` keys-    then return $! km-    else do-      let DebugModeCli{snoMore} = fdebugCli fs-      if snoMore then return firstKM-      else promptGetKey fs keys frame---- TODO: avoid unsafePerformIO; but server state is a wrong idea, too-connMulti :: ConnMulti-{-# NOINLINE connMulti #-}-connMulti = unsafePerformIO $ do-  fromMulti <- newMVar undefined-  toMulti <- newTQueueIO-  return $! ConnMulti{..}---- | Augment a function that takes and returns keys.-getConfirmGeneric :: Monad m-                  => ([K.KM] -> a -> m K.KM)-                  -> [K.KM] -> a -> m Bool-getConfirmGeneric pGetKey clearKeys x = do-  let extraKeys = [ K.KM {key=K.Space, modifier=K.NoModifier}-                  , K.escKey ]-  km <- pGetKey (clearKeys ++ extraKeys) x-  return $! km /= K.escKey--flushFrames :: Frontend -> FactionId -> ReqMap -> IO ReqMap-flushFrames fs fid reqMap = do-  let queue = toListLQueue $ fromMaybe newLQueue $ EM.lookup fid reqMap-      reqMap2 = EM.delete fid reqMap-  mapM_ (displayAc fs) queue-  return $! reqMap2--displayAc :: Frontend -> AcFrame -> IO ()-displayAc fs (AcConfirm fr) = void $ getConfirmGeneric (promptGetKey fs) [] fr-displayAc fs (AcRunning fr) = fdisplay fs True (Just fr)-displayAc fs (AcNormal fr) = fdisplay fs False (Just fr)-displayAc fs AcDelay = fdisplay fs False Nothing--getSingleFrame :: AcFrame -> Maybe SingleFrame-getSingleFrame (AcConfirm fr) = Just fr-getSingleFrame (AcRunning fr) = Just fr-getSingleFrame (AcNormal fr) = Just fr-getSingleFrame AcDelay = Nothing--toSingles :: FactionId -> ReqMap -> [SingleFrame]-toSingles fid reqMap =-  let queue = toListLQueue $ fromMaybe newLQueue $ EM.lookup fid reqMap-  in mapMaybe getSingleFrame queue--fadeF :: Frontend -> Bool -> FactionId -> Text -> SingleFrame -> IO ()-fadeF fs out side pname frame = do-  let topRight = True-      lxsize = xsizeSingleFrame frame-      lysize = ysizeSingleFrame frame-      msg = "Player" <+> tshow (fromEnum side) <> ","-            <+> pname <> (if T.null pname then "" else ",")-            <+> "get ready!"-  animMap <- rndToIO $ fadeout out topRight lxsize lysize-  let sfTop = truncateToOverlay lxsize msg-      basicFrame = frame {sfTop}  -- overwrite the whole original overlay-      animFrs = renderAnim lxsize lysize basicFrame animMap-      frs | out = animFrs-            -- Empty frame to mark the fade-in end,-            -- to trim only to here if SPACE pressed.-          | otherwise = animFrs ++ [Nothing]-  mapM_ (fdisplay fs False) frs--insertFr :: FactionId -> AcFrame -> ReqMap -> ReqMap-insertFr fid fr reqMap =-  let queue = fromMaybe newLQueue $ EM.lookup fid reqMap-  in EM.insert fid (writeLQueue queue fr) reqMap---- Read UI requests from clients and send them to the frontend,--- separated by fadeout/fadein frame sequences, if needed.--- There may be many UI clients, but this function is only ever--- executed on one thread, so the frontend receives requests--- in a sequential way, without any random interleaving.-loopFrontend :: Frontend -> ConnMulti -> IO ()-loopFrontend fs ConnMulti{..} = loop Nothing EM.empty- where-  writeKM :: FactionId -> K.KM -> IO ()-  writeKM fid km = do-    fM <- takeMVar fromMulti-    let chanFrontend = fst $ snd fM fid-    atomically $ STM.writeTQueue chanFrontend km-    putMVar fromMulti fM--  flushFade :: SingleFrame -> Maybe (FactionId, SingleFrame)-            -> ReqMap -> FactionId-            -> IO ReqMap-  flushFade frontFr oldFidFrame reqMap fid =-    if Just fid == fmap fst oldFidFrame then-      return reqMap-    else do-      (nU, fCT) <- readMVar fromMulti-      let pname = snd $ fCT fid-      reqMap2 <- case oldFidFrame of-        Nothing -> return reqMap-        Just (oldFid, oldFrame) -> do-          reqMap2 <- flushFrames fs oldFid reqMap-          let singles = toSingles oldFid reqMap  -- not @reqMap2@!-              lastFrame = fromMaybe oldFrame $ listToMaybe $ reverse singles-          fadeF fs True fid pname lastFrame-          return $! reqMap2-      let singles = toSingles fid reqMap2-          firstFrame = fromMaybe frontFr $ listToMaybe singles-      -- TODO: @nU@ is unreliable, when some of UI players die;-      -- in the result a single players has unneeded fadeins.-      unless (isNothing oldFidFrame && nU < 2) $-        fadeF fs False fid pname firstFrame-      flushFrames fs fid reqMap2--  loop :: Maybe (FactionId, SingleFrame) -> ReqMap -> IO ()-  loop oldFidFrame reqMap = do-    (fid, efr) <- atomically $ STM.readTQueue toMulti-    case efr of-      FrontFrame{..} | Just (oldFid, oldFrame) <- oldFidFrame-                     , fid == oldFid -> do-        displayAc fs frontAc-        let frame = fromMaybe oldFrame $ getSingleFrame frontAc-        loop (Just (fid, frame)) reqMap-      FrontFrame{..} -> do-        let reqMap2 = insertFr fid frontAc reqMap-        loop oldFidFrame reqMap2-      FrontKey{..} -> do-        reqMap2 <- flushFade frontFr oldFidFrame reqMap fid-        km <- promptGetKey fs frontKM frontFr-        writeKM fid km-        loop (Just (fid, frontFr)) reqMap2-      FrontSlides{frontSlides = []} -> return ()-      FrontSlides{frontSlides = frontSlides@(fr1 : _), ..} -> do-        reqMap2 <- flushFade fr1 oldFidFrame reqMap fid-        let displayFrs frs =-              case frs of-                [] -> assert `failure` "null slides" `twith` fid-                [x] -> do-                  fdisplay fs False (Just x)-                  writeKM fid K.KM {key=K.Space, modifier=K.NoModifier}-                  return x-                x : xs -> do-                  go <- getConfirmGeneric (promptGetKey fs) frontClear x-                  if go then displayFrs xs-                  else do-                    writeKM fid K.escKey-                    return x-        frLast <- displayFrs frontSlides-        loop (Just (fid, frLast)) reqMap2-      FrontFinish ->-        return ()  -- TODO: apply modified flushFrames to fid-        -- Do not loop again.
− Game/LambdaHack/Frontend/Chosen.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE CPP #-}--- | Re-export the operations of the chosen raw frontend--- (determined at compile time with cabal flags).-module Game.LambdaHack.Frontend.Chosen-  ( Frontend(..), chosenStartup, stdStartup, noStartup-  , frontendName-  ) where--import Game.LambdaHack.Common.Animation (DebugModeCli (..), SingleFrame (..))-import qualified Game.LambdaHack.Common.Key as K--#ifdef VTY-import qualified Game.LambdaHack.Frontend.Vty as Chosen-#elif CURSES-import qualified Game.LambdaHack.Frontend.Curses as Chosen-#else-import qualified Game.LambdaHack.Frontend.Gtk as Chosen-#endif--import qualified Game.LambdaHack.Frontend.Std as Std---- | The name of the chosen frontend.-frontendName :: String-frontendName = Chosen.frontendName--data Frontend = Frontend-  { fdisplay      :: Bool -> Maybe SingleFrame -> IO ()-  , fpromptGetKey :: SingleFrame -> IO K.KM-  , fdebugCli     :: !DebugModeCli-  }--chosenStartup :: DebugModeCli -> (Frontend -> IO ()) -> IO ()-chosenStartup fdebugCli cont =-  Chosen.startup fdebugCli $ \fs ->-    cont $ Frontend-      { fdisplay = Chosen.fdisplay fs-      , fpromptGetKey = Chosen.fpromptGetKey fs-      , fdebugCli-      }--stdStartup :: DebugModeCli -> (Frontend -> IO ()) -> IO ()-stdStartup fdebugCli cont =-  Std.startup fdebugCli $ \fs ->-    cont $ Frontend-      { fdisplay = Std.fdisplay fs-      , fpromptGetKey = Std.fpromptGetKey fs-      , fdebugCli-      }--noStartup :: DebugModeCli -> (Frontend -> IO ()) -> IO ()-noStartup fdebugCli cont =-    cont $ Frontend-      { fdisplay = \_ _ -> return ()-      , fpromptGetKey = \_ -> return K.escKey-      , fdebugCli-      }
− Game/LambdaHack/Frontend/Curses.hs 
@@ -1,162 +0,0 @@--- | Text frontend based on HSCurses. This frontend is not fully supported--- due to the limitations of the curses library (keys, colours, last character--- of the last line).-module Game.LambdaHack.Frontend.Curses-  ( -- * Session data type for the frontend-    FrontendSession-    -- * The output and input operations-  , fdisplay, fpromptGetKey-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import Data.Char (chr, ord)-import qualified Data.Map.Strict as M-import qualified Data.Text as T-import qualified UI.HSCurses.Curses as C-import qualified UI.HSCurses.CursesHelper as C--import Game.LambdaHack.Common.Animation-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Key as K-import Game.LambdaHack.Common.Msg---- | Session data maintained by the frontend.-data FrontendSession = FrontendSession-  { swin      :: !C.Window  -- ^ the window to draw to-  , sstyles   :: !(M.Map Color.Attr C.CursesStyle)-      -- ^ map from fore/back colour pairs to defined curses styles-  , sdebugCli :: !DebugModeCli  -- ^ client configuration-  }---- | The name of the frontend.-frontendName :: String-frontendName = "curses"---- | Starts the main program loop using the frontend input and output.-startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-startup sdebugCli k = do-  C.start---  C.keypad C.stdScr False  -- TODO: may help to fix xterm keypad on Ubuntu-  void $ C.cursSet C.CursorInvisible-  let s = [ (Color.Attr{fg, bg}, C.Style (toFColor fg) (toBColor bg))-          | fg <- [minBound..maxBound],-            -- No more color combinations possible: 16*4, 64 is max.-            bg <- Color.legalBG ]-  nr <- C.colorPairs-  when (nr < length s) $-    C.end >> (assert `failure` "terminal has too few color pairs" `twith` nr)-  let (ks, vs) = unzip s-  ws <- C.convertStyles vs-  let swin = C.stdScr-      sstyles = M.fromList (zip ks ws)-  k FrontendSession{..}-  C.end---- | 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-  let SingleFrame{sfLevel} = overlayOverlay rawSF-  -- let defaultStyle = C.defaultCursesStyle-  -- Terminals with white background require this:-  let defaultStyle = sstyles M.! Color.defAttr-  C.erase-  C.setStyle defaultStyle-  -- We need to remove the last character from the status line,-  -- because otherwise it would overflow a standard size xterm window,-  -- due to the curses historical limitations.-  let sfLevelDecoded = map decodeLine sfLevel-      level = init sfLevelDecoded ++ [init $ last sfLevelDecoded]-      nm = zip [0..] $ map (zip [0..]) level-  sequence_ [ C.setStyle (M.findWithDefault defaultStyle acAttr sstyles)-              >> C.mvWAddStr swin (y + 1) x [acChar]-            | (y, line) <- nm, (x, Color.AttrChar{..}) <- line ]-  C.refresh---- | Input key via the frontend.-nextEvent :: FrontendSession -> IO K.KM-nextEvent FrontendSession{sdebugCli=DebugModeCli{snoMore}} =-  if snoMore then return K.escKey-  else keyTranslate `fmap` C.getKey C.refresh---- | Display a prompt, wait for any key.-fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM-fpromptGetKey sess frame = do-  fdisplay sess True $ Just frame-  nextEvent sess--keyTranslate :: C.Key -> K.KM-keyTranslate e = (\(key, modifier) -> K.KM {..}) $-  case e of-    C.KeyChar '\ESC' -> (K.Esc,     K.NoModifier)-    C.KeyExit        -> (K.Esc,     K.NoModifier)-    C.KeyChar '\n'   -> (K.Return,  K.NoModifier)-    C.KeyChar '\r'   -> (K.Return,  K.NoModifier)-    C.KeyEnter       -> (K.Return,  K.NoModifier)-    C.KeyChar ' '    -> (K.Space,   K.NoModifier)-    C.KeyChar '\t'   -> (K.Tab,     K.NoModifier)-    C.KeyBTab        -> (K.BackTab, K.NoModifier)-    C.KeyBackspace   -> (K.BackSpace, K.NoModifier)-    C.KeyUp          -> (K.Up,      K.NoModifier)-    C.KeyDown        -> (K.Down,    K.NoModifier)-    C.KeyLeft        -> (K.Left,    K.NoModifier)-    C.KeySLeft       -> (K.Left,    K.NoModifier)-    C.KeyRight       -> (K.Right,   K.NoModifier)-    C.KeySRight      -> (K.Right,   K.NoModifier)-    C.KeyHome        -> (K.Home,    K.NoModifier)-    C.KeyEnd         -> (K.End,     K.NoModifier)-    C.KeyPPage       -> (K.PgUp,    K.NoModifier)-    C.KeyNPage       -> (K.PgDn,    K.NoModifier)-    C.KeyBeg         -> (K.Begin,   K.NoModifier)-    C.KeyB2          -> (K.Begin,   K.NoModifier)-    C.KeyClear       -> (K.Begin,   K.NoModifier)-    -- No KP_ keys; see <https://github.com/skogsbaer/hscurses/issues/10>-    -- TODO: try to get the Control modifier for keypad keys from the escape-    -- gibberish and use Control-keypad for KP_ movement.-    C.KeyChar c-      -- This case needs to be considered after Tab, since, apparently,-      -- on some terminals ^i == Tab and Tab is more important for us.-      | ord '\^A' <= ord c && ord c <= ord '\^Z' ->-        -- Alas, only lower-case letters.-        (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control)-        -- Movement keys are more important than leader picking,-        -- so disabling the latter and interpreting the keypad numbers-        -- as movement:-      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)-      | otherwise           -> (K.Char c,            K.NoModifier)-    _                       -> (K.Unknown (tshow e), K.NoModifier)--toFColor :: Color.Color -> C.ForegroundColor-toFColor Color.Black     = C.BlackF-toFColor Color.Red       = C.DarkRedF-toFColor Color.Green     = C.DarkGreenF-toFColor Color.Brown     = C.BrownF-toFColor Color.Blue      = C.DarkBlueF-toFColor Color.Magenta   = C.PurpleF-toFColor Color.Cyan      = C.DarkCyanF-toFColor Color.White     = C.WhiteF-toFColor Color.BrBlack   = C.GreyF-toFColor Color.BrRed     = C.RedF-toFColor Color.BrGreen   = C.GreenF-toFColor Color.BrYellow  = C.YellowF-toFColor Color.BrBlue    = C.BlueF-toFColor Color.BrMagenta = C.MagentaF-toFColor Color.BrCyan    = C.CyanF-toFColor Color.BrWhite   = C.BrightWhiteF--toBColor :: Color.Color -> C.BackgroundColor-toBColor Color.Black     = C.BlackB-toBColor Color.Red       = C.DarkRedB-toBColor Color.Green     = C.DarkGreenB-toBColor Color.Brown     = C.BrownB-toBColor Color.Blue      = C.DarkBlueB-toBColor Color.Magenta   = C.PurpleB-toBColor Color.Cyan      = C.DarkCyanB-toBColor Color.White     = C.WhiteB-toBColor _               = C.BlackB  -- a limitation of curses
− Game/LambdaHack/Frontend/Gtk.hs 
@@ -1,453 +0,0 @@--- | Text frontend based on Gtk.-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-module Game.LambdaHack.Frontend.Gtk-  ( -- * Session data type for the frontend-    FrontendSession-    -- * The output and input operations-  , fdisplay, fpromptGetKey-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import Control.Concurrent-import Control.Exception.Assert.Sugar-import Control.Monad-import Control.Monad.Reader-import qualified Data.ByteString.Char8 as BS-import Data.IORef-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Graphics.UI.Gtk hiding (Point)-import System.Time--import Game.LambdaHack.Common.Animation-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Key as K-import Game.LambdaHack.Utils.LQueue--data FrameState =-    FPushed  -- frames stored in a queue, to be drawn in equal time intervals-      { fpushed :: !(LQueue (Maybe GtkFrame))  -- ^ screen output channel-      , fshown  :: !GtkFrame                   -- ^ last full frame shown-      }-  | FNone  -- no frames stored---- | Session data maintained by the frontend.-data FrontendSession = FrontendSession-  { sview       :: !TextView                    -- ^ the widget to draw to-  , stags       :: !(M.Map Color.Attr TextTag)  -- ^ text color tags for fg/bg-  , schanKey    :: !(Chan K.KM)                 -- ^ channel for keyboard input-  , sframeState :: !(MVar FrameState)-      -- ^ State of the frame finite machine. This mvar is locked-      -- for a short time only, because it's needed, among others,-      -- to display frames, which is done by a single polling thread,-      -- in real time.-  , slastFull   :: !(MVar (GtkFrame, Bool))-      -- ^ Most recent full (not empty, not repeated) frame received-      -- and if any empty frame followed it. This mvar is locked-      -- for longer intervals to ensure that threads (possibly many)-      -- add frames in an orderly manner, which is not done in real time,-      -- though sometimes the frame display subsystem has to poll-      -- for a frame, in which case the locking interval becomes meaningful.-  , sdebugCli   :: !DebugModeCli  -- ^ client configuration-  }--data GtkFrame = GtkFrame-  { gfChar :: !BS.ByteString-  , gfAttr :: ![[TextTag]]-  }-  deriving Eq--dummyFrame :: GtkFrame-dummyFrame = GtkFrame BS.empty []---- | Perform an operation on the frame queue.-onQueue :: (LQueue (Maybe GtkFrame) -> LQueue (Maybe GtkFrame))-        -> FrontendSession -> IO ()-onQueue f FrontendSession{sframeState} = do-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      putMVar sframeState FPushed{fpushed = f fpushed, ..}-    _ ->-      putMVar sframeState fs---- | The name of the frontend.-frontendName :: String-frontendName = "gtk"---- | Starts GTK. The other threads have to be spawned--- after gtk is initialized, because they call @postGUIAsync@,--- and need @sview@ and @stags@. Because of Windows, GTK needs to be--- on a bound thread, so we can't avoid the communication overhead--- of bound threads, so there's no point spawning a separate thread for GTK.-startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-startup = runGtk---- | Sets up and starts the main GTK loop providing input and output.-runGtk :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-runGtk sdebugCli@DebugModeCli{sfont} cont = do-  -- Init GUI.-  unsafeInitGUIForThreadedRTS-  -- Text attributes.-  ttt <- textTagTableNew-  stags <- fmap M.fromList $-             mapM (\ ak -> do-                      tt <- textTagNew Nothing-                      textTagTableAdd ttt tt-                      doAttr tt ak-                      return (ak, tt))-               [ Color.Attr{fg, bg}-               | fg <- [minBound..maxBound], bg <- Color.legalBG ]-  -- Text buffer.-  tb <- textBufferNew (Just ttt)-  -- Create text view. TODO: use GtkLayout or DrawingArea instead of TextView?-  sview <- textViewNewWithBuffer tb-  textViewSetEditable sview False-  textViewSetCursorVisible sview False-  -- Set up the channel for keyboard input.-  schanKey <- newChan-  -- Set up the frame state.-  let frameState = FNone-  -- Create the session record.-  sframeState <- newMVar frameState-  slastFull <- newMVar (dummyFrame, False)-  let sess = FrontendSession{..}-  -- Fork the game logic thread. When logic ends, game exits.-  -- TODO: is postGUIAsync needed here?-  forkIO $ cont sess >> postGUIAsync mainQuit-  -- Fork the thread that periodically draws a frame from a queue, if any.-  forkIO $ pollFrames sess Nothing-  -- Fill the keyboard channel.-  sview `on` keyPressEvent $ do-    n <- eventKeyName-    mods <- eventModifier-    let !key = K.keyTranslate n-        !modifier = modifierTranslate mods-    liftIO $ do-      unless (deadKey n) $-        -- Store the key in the channel.-        writeChan schanKey K.KM{key, modifier}-      return True-  -- Set the font specified in config, if any.-  f <- fontDescriptionFromString $ fromMaybe "" sfont-  widgetModifyFont sview (Just f)-  -- Prepare font chooser dialog.-  currentfont <- newIORef f-  sview `on` buttonPressEvent $ do-    but <- eventButton-    liftIO $ case but of-      RightButton -> do-        fsd <- fontSelectionDialogNew "Choose font"-        cf  <- readIORef currentfont  -- TODO: "Terminus,Monospace" fails-        fds <- fontDescriptionToString cf-        fontSelectionDialogSetFontName fsd fds-        fontSelectionDialogSetPreviewText fsd "eee...@.##+##"-        resp <- dialogRun fsd-        when (resp == ResponseOk) $ do-          fn <- fontSelectionDialogGetFontName fsd-          case fn of-            Just fn' -> do-              fd <- fontDescriptionFromString fn'-              writeIORef currentfont fd-              widgetModifyFont sview (Just fd)-            Nothing  -> return ()-        widgetDestroy fsd-        return True-      _ -> return False-  -- Modify default colours.-  let black = Color minBound minBound minBound  -- Color.defBG == Color.Black-      white = Color 0xC500 0xBC00 0xB800        -- Color.defFG == Color.White-  widgetModifyBase sview StateNormal black-  widgetModifyText sview StateNormal white-  -- Set up the main window.-  w <- windowNew-  containerAdd w sview-  onDestroy w mainQuit-  widgetShowAll w-  mainGUI---- | Output to the screen via the frontend.-output :: FrontendSession  -- ^ frontend session data-       -> GtkFrame         -- ^ the screen frame to draw-       -> IO ()-output FrontendSession{sview, stags} GtkFrame{..} = do  -- new frame-  tb <- textViewGetBuffer sview-  let attrs = zip [0..] gfAttr-      defAttr = stags M.! Color.defAttr-  textBufferSetByteString tb gfChar-  mapM_ (setTo tb defAttr 0) attrs--setTo :: TextBuffer -> TextTag -> Int -> (Int, [TextTag]) -> IO ()-setTo _  _   _  (_,  [])         = return ()-setTo tb defAttr lx (ly, attr:attrs) = do-  ib <- textBufferGetIterAtLineOffset tb ly lx-  ie <- textIterCopy ib-  let setIter :: TextTag -> Int -> [TextTag] -> IO ()-      setIter previous repetitions [] = do-        textIterForwardChars ie repetitions-        when (previous /= defAttr) $-          textBufferApplyTag tb previous ib ie-      setIter previous repetitions (a:as)-        | a == previous =-            setIter a (repetitions + 1) as-        | otherwise = do-            textIterForwardChars ie repetitions-            when (previous /= defAttr) $-              textBufferApplyTag tb previous ib ie-            textIterForwardChars ib repetitions-            setIter a 1 as-  setIter attr 1 attrs---- | Maximal polls per second.-maxPolls :: Int -> Int-maxPolls maxFps = max 120 (2 * maxFps)--picoInMicro :: Int-picoInMicro = 1000000---- | Add a given number of microseconds to time.-addTime :: ClockTime -> Int -> ClockTime-addTime (TOD s p) mus = TOD s (p + fromIntegral (mus * picoInMicro))---- | The difference between the first and the second time, in microseconds.-diffTime :: ClockTime -> ClockTime -> Int-diffTime (TOD s1 p1) (TOD s2 p2) =-  fromIntegral (s1 - s2) * picoInMicro +-  fromIntegral (p1 - p2) `div` picoInMicro--microInSec :: Int-microInSec = 1000000--defaultMaxFps :: Int-defaultMaxFps = 15---- | Poll the frame queue often and draw frames at fixed intervals.-pollFrames :: FrontendSession -> Maybe ClockTime -> IO ()-pollFrames sess@FrontendSession{sdebugCli=DebugModeCli{smaxFps}}-           (Just setTime) = do-  -- Check if the time is up.-  let maxFps = fromMaybe defaultMaxFps smaxFps-  curTime <- getClockTime-  let diffSetCur = diffTime setTime curTime-  if diffSetCur > microInSec `div` maxPolls maxFps-    then do-      -- Delay half of the time difference.-      threadDelay $ diffTime curTime setTime `div` 2-      pollFrames sess $ Just setTime-    else-      -- Don't delay, because time is up!-      pollFrames sess Nothing-pollFrames sess@FrontendSession{sframeState, sdebugCli=DebugModeCli{..}}-           Nothing = do-  -- Time is up, check if we actually wait for anyting.-  let maxFps = fromMaybe defaultMaxFps smaxFps-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      case tryReadLQueue fpushed of-        Just (Just frame, queue) -> do-          -- The frame has arrived so send it for drawing and update delay.-          putMVar sframeState FPushed{fpushed = queue, fshown = frame}-          -- Count the time spent outputting towards the total frame time.-          curTime <- getClockTime-          -- Wait until the frame is drawn.-          postGUISync $ output sess frame-          -- Regardless of how much time drawing took, wait at least-          -- half of the normal delay time. This can distort the large-scale-          -- frame rhythm, but makes sure this frame can at all be seen.-          -- If the main GTK thread doesn't lag, large-scale rhythm will be OK.-          -- TODO: anyway, it's GC that causes visible snags, most probably.-          threadDelay $ microInSec `div` (maxFps * 2)-          pollFrames sess $ Just $ addTime curTime $ microInSec `div` maxFps-        Just (Nothing, queue) -> do-          -- Delay requested via an empty frame.-          putMVar sframeState FPushed{fpushed = queue, ..}-          unless snoDelay $-            -- There is no problem if the delay is a bit delayed.-            threadDelay $ microInSec `div` maxFps-          pollFrames sess Nothing-        Nothing -> do-          -- The queue is empty, the game logic thread lags.-          putMVar sframeState fs-          -- Time is up, the game thread is going to send a frame,-          -- (otherwise it would change the state), so poll often.-          threadDelay $ microInSec `div` maxPolls maxFps-          pollFrames sess Nothing-    _ -> 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-      -- in creating frames in case one of the further frames is slow-      -- to generate and would normally cause a jerky delay in drawing.-      threadDelay $ microInSec `div` (maxFps * 2)-      pollFrames sess Nothing---- | 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-  let FrontendSession{sframeState, slastFull} = sess-  -- Full evaluation is done outside the mvar locks.-  let !frame = case rawFrame of-        Nothing -> Nothing-        Just fr -> Just $! evalFrame sess fr-  -- Lock frame addition.-  (lastFrame, anyFollowed) <- takeMVar slastFull-  -- Comparison of frames is done outside the frame queue mvar lock.-  let nextFrame = if frame == Just lastFrame-                  then Nothing  -- no sense repeating-                  else frame-  -- Lock frame queue.-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      putMVar sframeState-      $ if isNothing nextFrame && anyFollowed-        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-      -- 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{..}-  case nextFrame of-    Nothing -> putMVar slastFull (lastFrame, True)-    Just f  -> putMVar slastFull (f, noDelay)--evalFrame :: FrontendSession -> SingleFrame -> GtkFrame-evalFrame FrontendSession{stags} rawSF =-  let SingleFrame{sfLevel} = overlayOverlay rawSF-      sfLevelDecoded = map decodeLine sfLevel-      levelChar = unlines $ map (map Color.acChar) sfLevelDecoded-      gfChar = BS.pack $ init levelChar-      -- Strict version of @map (map ((stags M.!) . fst)) sfLevelDecoded@.-      gfAttr  = reverse $ foldl' ff [] sfLevelDecoded-      ff ll l = reverse (foldl' f [] l) : ll-      f l ac  = let !tag = stags M.! Color.acAttr ac in tag : l-  in GtkFrame{..}---- | Trim current frame queue and display the most recent frame, if any.-trimFrameState :: FrontendSession -> IO ()-trimFrameState sess@FrontendSession{sframeState} = do-  -- Take the lock to wipe out the frame queue, unless it's empty already.-  fs <- takeMVar sframeState-  case fs of-    FPushed{..} ->-      -- Remove all but the last element of the frame queue.-      -- The kept (and displayed) last element ensures that-      -- @slastFull@ is not invalidated.-      case lastLQueue fpushed of-        Just frame -> do-          -- Comparison is done inside the mvar lock, this time, but it's OK,-          -- since we wipe out the queue anyway, not draw it concurrently.-          let lastFrame = fshown-              nextFrame = if frame == lastFrame-                          then Nothing  -- no sense repeating-                          else Just frame-          -- Draw the last frame ASAP.-          maybe skip (postGUIAsync . output sess) nextFrame-        Nothing -> return ()-    FNone -> return ()-  -- Wipe out the frame queue. Release the lock.-  putMVar sframeState FNone---- | 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---- Display all queued frames, synchronously.-displayAllFramesSync :: FrontendSession -> FrameState -> IO ()-displayAllFramesSync sess@FrontendSession{sdebugCli=DebugModeCli{..}} fs = do-  let maxFps = fromMaybe defaultMaxFps smaxFps-  case fs of-    FPushed{..} ->-      case tryReadLQueue fpushed of-        Just (Just frame, queue) -> do-          -- Display synchronously.-          postGUISync $ output sess frame-          threadDelay $ microInSec `div` maxFps-          displayAllFramesSync sess FPushed{fpushed = queue, fshown = frame}-        Just (Nothing, queue) -> do-          -- Delay requested via an empty frame.-          unless snoDelay $-            threadDelay $ microInSec `div` maxFps-          displayAllFramesSync sess FPushed{fpushed = queue, ..}-        Nothing ->-          -- The queue is empty.-          return ()-    _ ->-      -- Not in Push state to start with.-      return ()---- | Display a prompt, wait for any key.--- Starts in Push mode, ends in Push or None mode.--- Syncs with the drawing threads by showing the last or all queued frames.-fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM-fpromptGetKey sess@FrontendSession{sdebugCli=DebugModeCli{snoMore}, ..}-              frame = do-  pushFrame sess True True $ Just frame-  if snoMore then do-    -- Show all frames synchronously. Keys completely ignored. TODO: K.Space-    fs <- takeMVar sframeState-    displayAllFramesSync sess fs-    putMVar sframeState FNone-    return K.escKey-  else do-    km <- readChan schanKey-    case km of-      K.KM{key=K.Space, modifier=K.NoModifier} ->-        -- Drop frames up to the first empty frame.-        -- Keep the last non-empty frame, if any.-        -- Pressing SPACE repeatedly can be used to step-        -- through intermediate stages of an animation,-        -- whereas any other key skips the whole animation outright.-        onQueue dropStartLQueue sess-      _ ->-        -- Show the last non-empty frame and empty the queue.-        trimFrameState sess-    return km---- | Tells a dead key.-deadKey :: String -> Bool-deadKey x = case x of-  "Shift_L"          -> True-  "Shift_R"          -> True-  "Control_L"        -> True-  "Control_R"        -> True-  "Super_L"          -> True-  "Super_R"          -> True-  "Menu"             -> True-  "Alt_L"            -> True-  "Alt_R"            -> True-  "ISO_Level2_Shift" -> True-  "ISO_Level3_Shift" -> True-  "ISO_Level2_Latch" -> True-  "ISO_Level3_Latch" -> True-  "Num_Lock"         -> True-  "Caps_Lock"        -> True-  _                  -> False---- | Translates modifiers to our own encoding.-modifierTranslate :: [Modifier] -> K.Modifier-modifierTranslate mods =-  if Control `elem` mods then K.Control else K.NoModifier--doAttr :: TextTag -> Color.Attr -> IO ()-doAttr tt attr@Color.Attr{fg, bg}-  | attr == Color.defAttr = return ()-  | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg]-  | bg == Color.defBG = set tt [textTagForeground := Color.colorToRGB fg]-  | otherwise         = set tt [textTagForeground := Color.colorToRGB fg,-                                textTagBackground := Color.colorToRGB bg]
− Game/LambdaHack/Frontend/Std.hs 
@@ -1,75 +0,0 @@--- | Text frontend based on stdin/stdout, intended for bots.-module Game.LambdaHack.Frontend.Std-  ( -- * Session data type for the frontend-    FrontendSession-    -- * The output and input operations-  , fdisplay, fpromptGetKey-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import qualified Data.ByteString.Char8 as BS-import Data.Char (chr, ord)-import qualified System.IO as SIO--import Game.LambdaHack.Common.Animation-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Key as K---- | No session data needs to be maintained by this frontend.-data FrontendSession = FrontendSession-  { sdebugCli :: !DebugModeCli  -- ^ client configuration-  }---- | The name of the frontend.-frontendName :: String-frontendName = "std"---- | Starts the main program loop using the frontend input and output.-startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-startup sdebugCli k = k FrontendSession{..}---- | 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) =-  let SingleFrame{sfLevel} = overlayOverlay rawSF-      bs = map (BS.pack . map Color.acChar . decodeLine) sfLevel ++ [BS.empty]-  in mapM_ BS.putStrLn bs---- | Input key via the frontend.-nextEvent :: FrontendSession -> IO K.KM-nextEvent FrontendSession{sdebugCli=DebugModeCli{snoMore}} =-  if snoMore then return K.escKey-  else do-    l <- BS.hGetLine SIO.stdin-    let c = case BS.uncons l of-          Nothing -> '\n'  -- empty line counts as RET-          Just (hd, _) -> hd-    return $! keyTranslate c---- | Display a prompt, wait for any key.-fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM-fpromptGetKey sess frame = do-  fdisplay sess True $ Just frame-  nextEvent sess--keyTranslate :: Char -> K.KM-keyTranslate e = (\(key, modifier) -> K.KM {..}) $-  case e of-    '\ESC' -> (K.Esc,     K.NoModifier)-    '\n'   -> (K.Return,  K.NoModifier)-    '\r'   -> (K.Return,  K.NoModifier)-    ' '    -> (K.Space,   K.NoModifier)-    '\t'   -> (K.Tab,     K.NoModifier)-    c | ord '\^A' <= ord c && ord c <= ord '\^Z' ->-        -- Alas, only lower-case letters.-        (K.Char $ chr $ ord c - ord '\^A' + ord 'a', K.Control)-        -- Movement keys are more important than leader picking,-        -- so disabling the latter and interpreting the keypad numbers-        -- as movement:-      | c `elem` ['1'..'9'] -> (K.KP c,              K.NoModifier)-      | otherwise           -> (K.Char c,            K.NoModifier)
− Game/LambdaHack/Frontend/Vty.hs 
@@ -1,135 +0,0 @@--- | Text frontend based on Vty.-module Game.LambdaHack.Frontend.Vty-  ( -- * Session data type for the frontend-    FrontendSession-    -- * The output and input operations-  , fdisplay, fpromptGetKey-    -- * Frontend administration tools-  , frontendName, startup-  ) where--import Graphics.Vty-import qualified Graphics.Vty as Vty--import Game.LambdaHack.Common.Animation-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Key as K-import Game.LambdaHack.Common.Msg---- | Session data maintained by the frontend.-data FrontendSession = FrontendSession-  { svty      :: !Vty  -- internal vty session-  , sdebugCli :: !DebugModeCli  -- ^ client configuration-      -- ^ Configuration of the frontend session.-  }---- | The name of the frontend.-frontendName :: String-frontendName = "vty"---- | Starts the main program loop using the frontend input and output.-startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO ()-startup sdebugCli k = do-  svty <- mkVty-  k FrontendSession{..}-  Vty.shutdown svty---- | 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) =-  let SingleFrame{sfLevel} = overlayOverlay rawSF-      img = (foldr (<->) empty_image-             . map (foldr (<|>) empty_image-                      . map (\ Color.AttrChar{..} ->-                                char (setAttr acAttr) acChar)))-            $ map decodeLine sfLevel-      pic = pic_for_image img-  in update svty pic---- | Input key via the frontend.-nextEvent :: FrontendSession -> IO K.KM-nextEvent sess@FrontendSession{svty, sdebugCli=DebugModeCli{snoMore}} =-  if snoMore then return K.escKey-  else do-    e <- next_event svty-    case e of-      EvKey n mods -> do-        let key = keyTranslate n-            modifier = modifierTranslate mods-        return $! K.KM {key, modifier}-      _ -> nextEvent sess---- | Display a prompt, wait for any key.-fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM-fpromptGetKey sess frame = do-  fdisplay sess True $ Just frame-  nextEvent sess---- TODO: Ctrl-Home and Ctrl-End are the same as Home and End on some terminals--- so we should probably go back to using 0-9 (and Shift) for movement--- but let's wait until vty 5.0 is out and see if it helps.-keyTranslate :: Key -> K.Key-keyTranslate n =-  case n of-    KEsc          -> K.Esc-    KEnter        -> K.Return-    (KASCII ' ')  -> K.Space-    (KASCII '\t') -> K.Tab-    KBackTab      -> K.BackTab-    KBS           -> K.BackSpace-    KUp           -> K.Up-    KDown         -> K.Down-    KLeft         -> K.Left-    KRight        -> K.Right-    KHome         -> K.Home-    KEnd          -> K.End-    KPageUp       -> K.PgUp-    KPageDown     -> K.PgDn-    KBegin        -> K.Begin-    KNP5          -> K.Begin-    (KASCII c)    -> K.Char c-    _             -> K.Unknown (tshow n)---- | Translates modifiers to our own encoding.-modifierTranslate :: [Modifier] -> K.Modifier-modifierTranslate mods =-  if MCtrl `elem` mods then K.Control else K.NoModifier---- TODO: with vty 5.0 check if bold is still needed.--- A hack to get bright colors via the bold attribute. Depending on terminal--- settings this is needed or not and the characters really get bold or not.--- HSCurses does this by default, but in Vty you have to request the hack.-hack :: Color.Color -> Attr -> Attr-hack c a = if Color.isBright c then with_style a bold else a--setAttr :: Color.Attr -> Attr-setAttr Color.Attr{fg, bg} =--- This optimization breaks display for white background terminals:---  if (fg, bg) == Color.defAttr---  then def_attr---  else-  hack fg $ hack bg $-    def_attr { attr_fore_color = SetTo (aToc fg)-             , attr_back_color = SetTo (aToc bg) }--aToc :: Color.Color -> Color-aToc Color.Black     = black-aToc Color.Red       = red-aToc Color.Green     = green-aToc Color.Brown     = yellow-aToc Color.Blue      = blue-aToc Color.Magenta   = magenta-aToc Color.Cyan      = cyan-aToc Color.White     = white-aToc Color.BrBlack   = bright_black-aToc Color.BrRed     = bright_red-aToc Color.BrGreen   = bright_green-aToc Color.BrYellow  = bright_yellow-aToc Color.BrBlue    = bright_blue-aToc Color.BrMagenta = bright_magenta-aToc Color.BrCyan    = bright_cyan-aToc Color.BrWhite   = bright_white
+ Game/LambdaHack/SampleImplementation/SampleMonadClient.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving,+             MultiParamTypeClasses #-}+-- | The main game action monad type implementation. Just as any other+-- component of the library, this implementation can be substituted.+-- This module should not be imported anywhere except in 'Action'+-- to expose the executor to any code using the library.+module Game.LambdaHack.SampleImplementation.SampleMonadClient+  ( executorCli+  ) where++import Control.Applicative+import Control.Concurrent.STM+import qualified Control.Monad.IO.Class as IO+import Control.Monad.Trans.State.Strict hiding (State)+import Data.Maybe+import System.FilePath++import Game.LambdaHack.Atomic.HandleAtomicWrite+import Game.LambdaHack.Atomic.MonadAtomic+import Game.LambdaHack.Atomic.MonadStateWrite+import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.ProtocolClient+import Game.LambdaHack.Client.State+import Game.LambdaHack.Client.UI.MonadClientUI+import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.MonadStateRead+import qualified Game.LambdaHack.Common.Save as Save+import Game.LambdaHack.Common.State+import Game.LambdaHack.Server.ProtocolServer++data CliState resp req = CliState+  { cliState   :: !State        -- ^ current global state+  , cliClient  :: !StateClient  -- ^ current client state+  , cliDict    :: !(ChanServer resp req)+                                -- ^ this client connection information+  , cliToSave  :: !(Save.ChanSave (State, StateClient))+                                -- ^ connection to the save thread+  , cliSession :: SessionUI     -- ^ UI setup data, empty for AI clients+  }++-- | Server state transformation monad.+newtype CliImplementation resp req a =+    CliImplementation {runCliImplementation :: StateT (CliState resp req) IO a}+  deriving (Monad, Functor, Applicative)++instance MonadStateRead (CliImplementation resp req) where+  getState    = CliImplementation $ gets cliState+  getsState f = CliImplementation $ gets $ f . cliState++instance MonadStateWrite (CliImplementation resp req) where+  modifyState f = CliImplementation $ state $ \cliS ->+    let newCliS = cliS {cliState = f $ cliState cliS}+    in newCliS `seq` ((), newCliS)+  putState    s = CliImplementation $ state $ \cliS ->+    let newCliS = cliS {cliState = s}+    in newCliS `seq` ((), newCliS)++instance MonadClient (CliImplementation resp req) where+  getClient      = CliImplementation $ gets cliClient+  getsClient   f = CliImplementation $ gets $ f . cliClient+  modifyClient f = CliImplementation $ state $ \cliS ->+    let newCliS = cliS {cliClient = f $ cliClient cliS}+    in newCliS `seq` ((), newCliS)+  putClient    s = CliImplementation $ state $ \cliS ->+    let newCliS = cliS {cliClient = s}+    in newCliS `seq` ((), newCliS)+  liftIO         = CliImplementation . IO.liftIO+  saveChanClient = CliImplementation $ gets cliToSave++instance MonadClientUI (CliImplementation resp req) where+  getsSession f  = CliImplementation $ gets $ f . cliSession+  liftIO         = CliImplementation . IO.liftIO++instance MonadClientReadResponse resp (CliImplementation resp req) where+  receiveResponse     = CliImplementation $ do+    ChanServer{responseS} <- gets cliDict+    IO.liftIO $ atomically . readTQueue $ responseS++instance MonadClientWriteRequest req (CliImplementation resp req) where+  sendRequest scmd = CliImplementation $ do+    ChanServer{requestS} <- gets cliDict+    IO.liftIO $ atomically . writeTQueue requestS $ scmd++instance MonadAtomic (CliImplementation resp req) where+  execAtomic = handleCmdAtomic++-- | Init the client, then run an action, with a given session,+-- state and history, in the @IO@ monad.+executorCli :: CliImplementation resp req ()+            -> SessionUI -> State -> StateClient -> ChanServer resp req+            -> IO ()+executorCli m cliSession cliState cliClient cliDict =+  let saveFile (_, cli2) =+        fromMaybe "save" (ssavePrefixCli (sdebugCli cli2))+        <.> saveName (sside cli2) (sisAI cli2)+      exe cliToSave =+        evalStateT (runCliImplementation m) CliState{..}+  in Save.wrapInSaves saveFile exe
+ Game/LambdaHack/SampleImplementation/SampleMonadServer.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | The main game action monad type implementation. Just as any other+-- component of the library, this implementation can be substituted.+-- This module should not be imported anywhere except in 'Action'+-- to expose the executor to any code using the library.+module Game.LambdaHack.SampleImplementation.SampleMonadServer+  ( executorSer+  ) where++import Control.Applicative+import qualified Control.Monad.IO.Class as IO+import Control.Monad.Trans.State.Strict hiding (State)+import qualified Data.EnumMap.Strict as EM+import Data.Maybe+import System.FilePath++import Game.LambdaHack.Atomic.BroadcastAtomicWrite+import Game.LambdaHack.Atomic.CmdAtomic+import Game.LambdaHack.Atomic.MonadAtomic+import Game.LambdaHack.Atomic.MonadStateWrite+import Game.LambdaHack.Common.MonadStateRead+import qualified Game.LambdaHack.Common.Save as Save+import Game.LambdaHack.Common.State+import Game.LambdaHack.Server.CommonServer+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.ProtocolServer+import Game.LambdaHack.Server.State++data SerState = SerState+  { serState  :: !State           -- ^ current global state+  , serServer :: !StateServer     -- ^ current server state+  , serDict   :: !ConnServerDict  -- ^ client-server connection information+  , serToSave :: !(Save.ChanSave (State, StateServer))+                                  -- ^ connection to the save thread+  }++-- | Server state transformation monad.+newtype SerImplementation a =+    SerImplementation {runSerImplementation :: StateT SerState IO a}+  deriving (Monad, Functor, Applicative)++instance MonadStateRead SerImplementation where+  getState    = SerImplementation $ gets serState+  getsState f = SerImplementation $ gets $ f . serState++instance MonadStateWrite SerImplementation where+  modifyState f = SerImplementation $ state $ \serS ->+    let newSerS = serS {serState = f $ serState serS}+    in newSerS `seq` ((), newSerS)+  putState    s = SerImplementation $ state $ \serS ->+    let newSerS = serS {serState = s}+    in newSerS `seq` ((), newSerS)++instance MonadServer SerImplementation where+  getServer      = SerImplementation $ gets serServer+  getsServer   f = SerImplementation $ gets $ f . serServer+  modifyServer f = SerImplementation $ state $ \serS ->+    let newSerS = serS {serServer = f $ serServer serS}+    in newSerS `seq` ((), newSerS)+  putServer    s = SerImplementation $ state $ \serS ->+    let newSerS = serS {serServer = s}+    in newSerS `seq` ((), newSerS)+  liftIO         = SerImplementation . IO.liftIO+  saveChanServer = SerImplementation $ gets serToSave++instance MonadServerReadRequest SerImplementation where+  getDict      = SerImplementation $ gets serDict+  getsDict   f = SerImplementation $ gets $ f . serDict+  modifyDict f =+    SerImplementation $ modify $ \serS -> serS {serDict = f $ serDict serS}+  putDict    s =+    SerImplementation $ modify $ \serS -> serS {serDict = s}+  liftIO       = SerImplementation . IO.liftIO++-- | The game-state semantics of atomic game commands+-- as computed on the server.+instance MonadAtomic SerImplementation where+  execAtomic = handleAndBroadcastServer++-- | Send an atomic action to all clients that can see it.+handleAndBroadcastServer :: (MonadStateWrite m, MonadServerReadRequest m)+                         => CmdAtomic -> m ()+handleAndBroadcastServer atomic = do+  persOld <- getsServer sper+  knowEvents <- getsServer $ sknowEvents . sdebugSer+  handleAndBroadcast knowEvents persOld resetFidPerception resetLitInDungeon+                     sendUpdateAI sendUpdateUI atomic++-- | Run an action in the @IO@ monad, with undefined state.+executorSer :: SerImplementation () -> IO ()+executorSer m =+  let saveFile (_, ser) =+        fromMaybe "save" (ssavePrefixSer (sdebugSer ser))+        <.> saveName+      exe serToSave =+        evalStateT (runSerImplementation m)+          SerState { serState = emptyState+                   , serServer = emptyStateServer+                   , serDict = EM.empty+                   , serToSave+                   }+  in Save.wrapInSaves saveFile exe
Game/LambdaHack/Server.hs view
@@ -1,186 +1,58 @@--- | Semantics of server commands.+-- | Semantics of requests that are sent to the server.+-- -- See--- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Server   ( mainSer   ) where  import Control.Concurrent import qualified Control.Exception as Ex hiding (handle)-import qualified Data.Text as T-import System.Environment (getArgs) -import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Animation-import Game.LambdaHack.Common.ClientCmd+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.ServerCmd-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Frontend-import Game.LambdaHack.Server.Action-import Game.LambdaHack.Server.LoopAction-import Game.LambdaHack.Server.ServerSem+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-import Game.LambdaHack.Utils.Thread --- | The semantics of server commands. The resulting boolean value--- indicates if the command took some time.-cmdSerSem :: (MonadAtomic m, MonadServer m) => CmdSer -> m Bool-cmdSerSem cmd = case cmd of-  CmdTakeTimeSer cmd2 -> cmdSerSemTakeTime cmd2 >> return True-  GameRestartSer aid t d names -> gameRestartSer aid t d names >> return False-  GameExitSer aid d -> gameExitSer aid d >> return False-  GameSaveSer _ -> gameSaveSer >> return False--cmdSerSemTakeTime :: (MonadAtomic m, MonadServer m) => CmdTakeTimeSer -> m ()-cmdSerSemTakeTime cmd = case cmd of-  MoveSer source target -> moveSer source target-  MeleeSer source target -> meleeSer source target-  DisplaceSer source target -> displaceSer source target-  AlterSer source tpos mfeat -> alterSer source tpos mfeat-  WaitSer aid -> waitSer aid-  PickupSer aid i k -> pickupSer aid i k-  DropSer aid iid k -> dropSer aid iid k-  ProjectSer aid p eps iid container -> projectSer aid p eps iid container-  ApplySer aid iid container -> applySer aid iid container-  TriggerSer aid mfeat -> triggerSer aid mfeat-  SetTrajectorySer aid -> setTrajectorySer aid--debugArgs :: IO DebugModeSer-debugArgs = do-  args <- getArgs-  let usage =-        [ "Configure debug options here, gameplay options in config.rules.ini."-        , "  --knowMap  reveal map for all clients in the next game"-        , "  --knowEvents  show all events in the next game (needs --knowMap)"-        , "  --sniffIn  display all incoming commands on console "-        , "  --sniffOut  display all outgoing commands on console "-        , "  --allClear  let all map tiles be translucent"-        , "  --gameMode m  start next game in the given mode"-        , "  --newGame  start a new game, overwriting the save file"-        , "  --difficulty n  set difficulty for all UI players to n"-        , "  --stopAfter n  exit this game session after around n seconds"-        , "  --benchmark  print stats, limit saving and other file operations"-        , "  --setDungeonRng s  set dungeon generation RNG seed to string s"-        , "  --setMainRng s  set the main game RNG seed to string s"-        , "  --dumpInitRngs  dump RNG states from the start of the game"-        , "  --dbgMsgSer  let the server emit its internal debug messages"-        , "  --font fn  use the given font for the main game window"-        , "  --maxFps n  display at most n frames per second"-        , "  --noDelay  don't maintain any requested delays between frames"-        , "  --noMore  auto-answer all prompts"-        , "  --noAnim  don't show any animations"-        , "  --savePrefix  prepend the text to all savefile names"-        , "  --frontendStd  use the simple stdout/stdin frontend"-        , "  --frontendNo  use no frontend at all (for AIvsAI benchmarks)"-        , "  --dbgMsgCli  let clients emit their internal debug messages"-        , "  --fovMode m  set a Field of View mode, where m can be"-        , "    Digital r, r > 0"-        , "    Permissive"-        , "    Shadow"-        , "    Blind"-        ]-      parseArgs [] = defDebugModeSer-      parseArgs ("--knowMap" : rest) =-        (parseArgs rest) {sknowMap = True}-      parseArgs ("--knowEvents" : rest) =-        (parseArgs rest) {sknowEvents = True}-      parseArgs ("--sniffIn" : rest) =-        (parseArgs rest) {sniffIn = True}-      parseArgs ("--sniffOut" : rest) =-        (parseArgs rest) {sniffOut = True}-      parseArgs ("--allClear" : rest) =-        (parseArgs rest) {sallClear = True}-      parseArgs ("--gameMode" : s : rest) =-        (parseArgs rest) {sgameMode = T.pack s}-      parseArgs ("--newGame" : rest) =-        let debugSer = parseArgs rest-        in debugSer { snewGameSer = True-                    , sdebugCli = (sdebugCli debugSer) {snewGameCli = True}}-      parseArgs ("--difficulty" : s : rest) =-        let debugSer = parseArgs rest-            diff = 5 - read s-        in debugSer { sdifficultySer = diff-                    , sdebugCli = (sdebugCli debugSer) {sdifficultyCli = diff}}-      parseArgs ("--stopAfter" : s : rest) =-        (parseArgs rest) {sstopAfter = Just $ read s}-      parseArgs ("--benchmark" : rest) =-        (parseArgs rest) {sbenchmark = True}-      parseArgs ("--setDungeonRng" : s : rest) =-        (parseArgs rest) {sdungeonRng = Just $ read s}-      parseArgs ("--setMainRng" : s : rest) =-        (parseArgs rest) {smainRng = Just $ read s}-      parseArgs ("--dumpInitRngs" : rest) =-        (parseArgs rest) {sdumpInitRngs = True}-      parseArgs ("--fovMode" : "Digital" : r : rest) | (read r :: Int) > 0 =-        (parseArgs rest) {sfovMode = Just $ Digital $ read r}-      parseArgs ("--fovMode" : mode : rest) =-        (parseArgs rest) {sfovMode = Just $ read mode}-      parseArgs ("--dbgMsgSer" : rest) =-        (parseArgs rest) {sdbgMsgSer = True}-      parseArgs ("--font" : s : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {sfont = Just s}}-      parseArgs ("--maxFps" : n : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli =-                       (sdebugCli debugSer) {smaxFps = Just $ read n}}-      parseArgs ("--noDelay" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {snoDelay = True}}-      parseArgs ("--noMore" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {snoMore = True}}-      parseArgs ("--noAnim" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {snoAnim = Just True}}-      parseArgs ("--savePrefix" : s : rest) =-        let debugSer = parseArgs rest-        in debugSer { ssavePrefixSer = Just s-                    , sdebugCli =-                        (sdebugCli debugSer) {ssavePrefixCli = Just s}}-      parseArgs ("--frontendStd" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendStd = True}}-      parseArgs ("--frontendNo" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendNo = True}}-      parseArgs ("--dbgMsgCli" : rest) =-        let debugSer = parseArgs rest-        in debugSer {sdebugCli = (sdebugCli debugSer) {sdbgMsgCli = True}}-      parseArgs _ = error $ unlines usage-  return $! parseArgs 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.-mainSer :: (MonadAtomic m, MonadConnServer m)-        => Kind.COps+mainSer :: (MonadAtomic m, MonadServerReadRequest m)+        => [String]+        -> Kind.COps         -> (m () -> IO ())         -> (Kind.COps -> DebugModeCli-            -> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer+            -> ((FactionId -> ChanServer ResponseUI RequestUI                  -> IO ())-                -> (FactionId -> ChanServer CmdClientAI CmdTakeTimeSer+                -> (FactionId -> ChanServer ResponseAI RequestAI                     -> IO ())                 -> IO ())             -> IO ())         -> IO ()-mainSer !copsSlow  -- evaluate fully to discover errors ASAP and free memory-        exeSer exeFront = do-  sdebugNxt <- debugArgs+mainSer args+        !copsSlow  -- evaluate fully to discover errors ASAP and free memory+        exeSer+        exeFront = do+  sdebugNxt <- debugArgs args   let cops = speedupCOps False copsSlow-      loopServer = loopSer sdebugNxt cmdSerSem       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 (loopServer executorUI executorAI cops))-          (threadDelay 1000000)  -- server crash, show the error eventually+          (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
− Game/LambdaHack/Server/Action.hs 
@@ -1,482 +0,0 @@--- | Game action monads and basic building blocks for human and computer--- player actions. Has no access to the the main action type.--- Does not export the @liftIO@ operation nor a few other implementation--- details.-module Game.LambdaHack.Server.Action-  ( -- * Action monads-    MonadServer( getServer, getsServer, putServer, modifyServer, saveServer )-  , MonadConnServer-  , tryRestore, updateConn, killAllClients, speedupCOps-    -- * Communication-  , sendUpdateAI, sendQueryAI, sendPingAI-  , sendUpdateUI, sendQueryUI, sendPingUI-    -- * Assorted primitives-  , debugPrint, dumpRngs-  , getSetGen, restoreScore, revealItems, deduceQuits-  , rndToAction, resetSessionStart, resetGameStart, elapsedSessionTimeGT-  , tellAllClipPS, tellGameClipPS-  , resetFidPerception, getPerFid-  , childrenServer-  ) where--import Control.Concurrent-import Control.Concurrent.STM (TQueue, atomically)-import qualified Control.Concurrent.STM as STM-import qualified Control.Exception as Ex hiding (handle)-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Control.Monad.State as St-import qualified Data.EnumMap.Strict as EM-import Data.Key (mapWithKeyM, mapWithKeyM_)-import Data.List-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.IO as T-import Game.LambdaHack.Utils.Thread-import System.Directory-import System.FilePath-import System.IO-import System.IO.Unsafe (unsafePerformIO)-import qualified System.Random as R-import System.Time--import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.AtomicCmd-import Game.LambdaHack.Common.ClientCmd-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.HighScore as HighScore-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Save-import qualified Game.LambdaHack.Common.Save as Save-import Game.LambdaHack.Common.ServerCmd-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import qualified Game.LambdaHack.Frontend as Frontend-import Game.LambdaHack.Server.Action.ActionClass-import Game.LambdaHack.Server.Fov-import Game.LambdaHack.Server.State-import Game.LambdaHack.Utils.File--debugPrint :: MonadServer m => Text -> m ()-debugPrint t = do-  debug <- getsServer $ sdbgMsgSer . sdebugSer-  when debug $ liftIO $ do-    T.hPutStrLn stderr t-    hFlush stderr---- | Update the cached perception for the selected level, for a faction.--- The assumption is the level, and only the level, has changed since--- the previous perception calculation.-resetFidPerception :: MonadServer m => FactionId -> LevelId -> m ()-resetFidPerception fid lid = do-  cops <- getsState scops-  lvl <- getLevel lid-  fovMode <- getsServer $ sfovMode . sdebugSer-  per <- getsState-         $ levelPerception cops (fromMaybe (Digital 12) fovMode) fid lid lvl-  let upd = EM.adjust (EM.adjust (const per) lid) fid-  modifyServer $ \ser -> ser {sper = upd (sper ser)}--getPerFid :: MonadServer m => FactionId -> LevelId -> m Perception-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-  return $! per---- | Dumps RNG states from the start of the game to a file.-dumpRngs :: MonadServer m => m ()-dumpRngs = do-  dataDir <- liftIO appDataDir-  let fn = dataDir </> "rngs.dump"-  rngs <- getsServer srngs-  liftIO $ writeFile fn (show rngs)--writeTQueueAI :: MonadConnServer m => CmdClientAI -> TQueue CmdClientAI -> m ()-writeTQueueAI cmd fromServer = do-  debug <- getsServer $ sniffOut . sdebugSer-  when debug $ do-    d <- debugCmdClientAI cmd-    liftIO $ T.hPutStrLn stderr d-  liftIO $ atomically $ STM.writeTQueue fromServer cmd--writeTQueueUI :: MonadConnServer m => CmdClientUI -> TQueue CmdClientUI -> m ()-writeTQueueUI cmd fromServer = do-  debug <- getsServer $ sniffOut . sdebugSer-  when debug $ do-    d <- debugCmdClientUI cmd-    liftIO $ T.hPutStrLn stderr d-  liftIO $ atomically $ STM.writeTQueue fromServer cmd--readTQueueAI :: MonadConnServer m => TQueue CmdTakeTimeSer -> m CmdTakeTimeSer-readTQueueAI toServer = do-  cmd <- liftIO $ atomically $ STM.readTQueue toServer-  debug <- getsServer $ sniffIn . sdebugSer-  when debug $ do-    let aid = aidCmdTakeTimeSer cmd-    d <- debugAid aid "CmdTakeTimeSer" cmd-    liftIO $ T.hPutStrLn stderr d-  return $! cmd--readTQueueUI :: MonadConnServer m => TQueue CmdSer -> m CmdSer-readTQueueUI toServer = do-  cmd <- liftIO $ atomically $ STM.readTQueue toServer-  debug <- getsServer $ sniffIn . sdebugSer-  when debug $ do-    let aid = aidCmdSer cmd-    d <- debugAid aid "CmdSer" cmd-    liftIO $ T.hPutStrLn stderr d-  return $! cmd--sendUpdateAI :: MonadConnServer m => FactionId -> CmdClientAI -> m ()-sendUpdateAI fid cmd = do-  conn <- getsDict $ snd . (EM.! fid)-  writeTQueueAI cmd $ fromServer conn--sendQueryAI :: MonadConnServer m => FactionId -> ActorId -> m CmdTakeTimeSer-sendQueryAI fid aid = do-  conn <- getsDict $ snd . (EM.! fid)-  writeTQueueAI (CmdQueryAI aid) $ fromServer conn-  readTQueueAI $ toServer conn--sendPingAI :: MonadConnServer m => FactionId -> m ()-sendPingAI fid = do-  conn <- getsDict $ snd . (EM.! fid)-  writeTQueueAI CmdPingAI $ fromServer conn-  -- debugPrint $ "AI client" <+> tshow fid <+> "pinged..."-  cmdHack <- readTQueueAI $ toServer conn-  -- debugPrint $ "AI client" <+> tshow fid <+> "responded."-  assert (cmdHack == WaitSer (toEnum (-1))) skip--sendUpdateUI :: MonadConnServer m => FactionId -> CmdClientUI -> m ()-sendUpdateUI fid cmd = do-  cs <- getsDict $ fst . (EM.! fid)-  case cs of-    Nothing -> assert `failure` "no channel for faction" `twith` fid-    Just (_, conn) ->-      writeTQueueUI cmd $ fromServer conn--sendQueryUI :: MonadConnServer m => FactionId -> ActorId -> m CmdSer-sendQueryUI fid aid = do-  cs <- getsDict $ fst . (EM.! fid)-  case cs of-    Nothing -> assert `failure` "no channel for faction" `twith` fid-    Just (_, conn) -> do-      writeTQueueUI (CmdQueryUI aid) $ fromServer conn-      readTQueueUI $ toServer conn--sendPingUI :: MonadConnServer m => FactionId -> m ()-sendPingUI fid = do-  cs <- getsDict $ fst . (EM.! fid)-  case cs of-    Nothing -> assert `failure` "no channel for faction" `twith` fid-    Just (_, conn) -> do-      writeTQueueUI CmdPingUI $ fromServer conn-      -- debugPrint $ "UI client" <+> tshow fid <+> "pinged..."-      cmdHack <- readTQueueUI $ toServer conn-      -- debugPrint $ "UI client" <+> tshow fid <+> "responded."-      assert (cmdHack == CmdTakeTimeSer (WaitSer (toEnum (-1)))) skip---- TODO: refactor wrt Game.LambdaHack.Common.Save--- | Read the high scores table. Return the empty table if no file.-restoreScore :: MonadServer m => Kind.COps -> m HighScore.ScoreTable-restoreScore Kind.COps{corule} = do-  let stdRuleset = Kind.stdRuleset corule-      scoresFile = rscoresFile stdRuleset-  dataDir <- liftIO appDataDir-  let path = dataDir </> scoresFile-  configExists <- liftIO $ doesFileExist path-  mscore <- liftIO $ do-    res <- Ex.try $-      if configExists then do-        s <- strictDecodeEOF path-        return $ Just s-      else return Nothing-    let handler :: Ex.SomeException -> IO (Maybe a)-        handler e = do-          let msg = "High score restore failed. The error message is:"-                    <+> (T.unwords . T.lines) (tshow e)-          delayPrint $ msg-          return Nothing-    either handler return res-  maybe (return HighScore.empty) return mscore---- | Generate a new score, register it and save.-registerScore :: MonadServer m => Status -> Maybe Actor -> FactionId -> m ()-registerScore status mbody fid = do-  cops@Kind.COps{corule} <- getsState scops-  assert (maybe True ((fid ==) . bfid) mbody) skip-  fact <- getsState $ (EM.! fid) . sfactionD-  assert (playerHuman $ gplayer fact) skip-  total <- case mbody of-    Just body -> getsState $ snd . calculateTotal body-    Nothing -> case gleader fact of-      Nothing -> return 0-      Just aid -> do-        b <- getsState $ getActorBody aid-        getsState $ snd . calculateTotal b-  let stdRuleset = Kind.stdRuleset corule-      scoresFile = rscoresFile stdRuleset-  dataDir <- liftIO appDataDir-  -- Re-read the table in case it's changed by a concurrent game.-  table <- restoreScore cops-  time <- getsState stime-  date <- liftIO getClockTime-  DebugModeSer{sdifficultySer} <- getsServer sdebugSer-  let path = dataDir </> scoresFile-      saveScore (ntable, _) =-        liftIO $ encodeEOF path (ntable :: HighScore.ScoreTable)-      diff | not $ playerUI $ gplayer fact = 0-           | otherwise = sdifficultySer-  maybe skip saveScore $ HighScore.register table total time status date diff--resetSessionStart :: MonadServer m => m ()-resetSessionStart = do-  sstart <- liftIO getClockTime-  modifyServer $ \ser -> ser {sstart}---- TODO: all this breaks when games are loaded; we'd need to save--- elapsed game clock time to fix this.-resetGameStart :: MonadServer m => m ()-resetGameStart = do-  sgstart <- liftIO getClockTime-  time <- getsState stime-  modifyServer $ \ser ->-    ser {sgstart, sallTime = timeAdd (sallTime ser) time}--elapsedSessionTimeGT :: MonadServer m => Int -> m Bool-elapsedSessionTimeGT stopAfter = do-  current <- liftIO getClockTime-  TOD s p <- getsServer sstart-  return $! TOD (s + fromIntegral stopAfter) p <= current--tellAllClipPS :: MonadServer m => m ()-tellAllClipPS = do-  bench <- getsServer $ sbenchmark . sdebugSer-  when bench $ do-    TOD s p <- getsServer sstart-    TOD sCur pCur <- liftIO getClockTime-    allTime <- getsServer sallTime-    gtime <- getsState stime-    let time = timeAdd allTime gtime-    let diff = fromIntegral sCur + fromIntegral pCur / 10e12-               - fromIntegral s - fromIntegral p / 10e12-        cps = fromIntegral (timeFit time timeClip) / diff :: Double-    debugPrint $ "Session time:" <+> tshow diff <> "s."-                 <+> "Average clips per second:" <+> tshow cps <> "."--tellGameClipPS :: MonadServer m => m ()-tellGameClipPS = do-  bench <- getsServer $ sbenchmark . sdebugSer-  when bench $ do-    TOD s p <- getsServer sgstart-    unless (s == 0) $ do  -- loaded game, don't report anything-      TOD sCur pCur <- liftIO getClockTime-      time <- getsState stime-      let diff = fromIntegral sCur + fromIntegral pCur / 10e12-                 - fromIntegral s - fromIntegral p / 10e12-          cps = fromIntegral (timeFit time timeClip) / diff :: Double-      debugPrint $ "Game time:" <+> tshow diff <> "s."-                   <+> "Average clips per second:" <+> tshow cps <> "."--revealItems :: (MonadAtomic m, MonadServer m)-            => Maybe FactionId -> Maybe Actor -> m ()-revealItems mfid mbody = do-  dungeon <- getsState sdungeon-  discoS <- getsServer sdisco-  let discover b iid _numPieces = do-        item <- getsState $ getItemBody iid-        let ik = fromJust $ jkind discoS item-        execCmdAtomic $ DiscoverA (blid b) (bpos b) iid ik-      f aid = do-        b <- getsState $ getActorBody aid-        let ourSide = maybe True (== bfid b) mfid-        when (ourSide && Just b /= mbody) $ mapActorItems_ (discover b) b-  mapDungeonActors_ f dungeon-  maybe skip (\b -> mapActorItems_ (discover b) b) mbody--quitF :: (MonadAtomic m, MonadServer m)-      => Maybe Actor -> Status -> FactionId -> m ()-quitF mbody status fid = do-  assert (maybe True ((fid ==) . bfid) mbody) skip-  fact <- getsState $ (EM.! fid) . sfactionD-  let oldSt = gquit fact-  case fmap 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 (playerUI $ gplayer fact) $ do-        revealItems (Just fid) mbody-      when (playerHuman $ gplayer fact) $ do-        registerScore status mbody fid-      execCmdAtomic $ QuitFactionA fid mbody oldSt $ Just status-      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}-  | stOutcome `elem` [Defeated, Camping, Restart, Conquer] =-    assert `failure` "no quitting to deduce" `twith` (status, body)-deduceQuits body status = do-  cops <- getsState scops-  let fid = bfid body-      mapQuitF statusF fids = mapM_ (quitF Nothing statusF) $ delete fid fids-  quitF (Just body) status fid-  let inGame fact = case fmap stOutcome $ gquit fact of-        Just Killed -> False-        Just Defeated -> False-        Just Restart -> False  -- effectively, commits suicide-        _ -> True-  factionD <- getsState sfactionD-  let assocsInGame = filter (inGame . snd) $ EM.assocs factionD-      keysInGame = map fst assocsInGame-      assocsNotHorror = filter (not . isHorrorFact cops . snd) assocsInGame-      assocsUI = filter (playerUI . gplayer . snd) assocsInGame-  case assocsNotHorror of-    _ | null assocsUI ->-      -- Only non-UI players left in the game and they all win.-      mapQuitF status{stOutcome=Conquer} keysInGame-    [] ->-      -- Only horrors remain, so they win.-      mapQuitF status{stOutcome=Conquer} keysInGame-    (_, fact1) : rest | all (not . isAtWar fact1 . fst) rest ->-      -- Nobody is at war any more, so all win.-      -- TODO: check not at war with each other.-      mapQuitF status{stOutcome=Conquer} keysInGame-    _ | stOutcome status == Escape -> do-      -- Otherwise, in a game with many warring teams alive,-      -- only complete Victory matters, until enough of them die.-      let (victors, losers) = partition (flip isAllied fid . snd) assocsInGame-      mapQuitF status{stOutcome=Escape} $ map fst victors-      mapQuitF status{stOutcome=Defeated} $ map fst losers-    _ -> return ()--tryRestore :: MonadServer m-           => Kind.COps -> DebugModeSer -> m (Maybe (State, StateServer))-tryRestore Kind.COps{corule} sdebugSer = do-  let stdRuleset = Kind.stdRuleset corule-      scoresFile = rscoresFile stdRuleset-      pathsDataFile = rpathsDataFile stdRuleset-      prefix = ssavePrefixSer sdebugSer-  let copies = [( "GameDefinition" </> scoresFile-                , scoresFile )]-      name = fromMaybe "save" prefix <.> saveName-  liftIO $ Save.restoreGame name copies pathsDataFile---- Global variable for all children threads of the server.-childrenServer :: MVar [MVar ()]-{-# NOINLINE childrenServer #-}-childrenServer = unsafePerformIO (newMVar [])---- | Update connections to the new definition of factions.--- Connect to clients in old or newly spawned threads--- that read and write directly to the channels.-updateConn :: (MonadAtomic m, MonadConnServer m)-           => (FactionId-               -> Frontend.ChanFrontend-               -> ChanServer CmdClientUI CmdSer-               -> IO ())-           -> (FactionId-               -> ChanServer CmdClientAI CmdTakeTimeSer-               -> IO ())-           -> m ()-updateConn executorUI executorAI = do-  -- Prepare connections based on factions.-  oldD <- getDict-  let mkChanServer :: IO (ChanServer c d)-      mkChanServer = do-        fromServer <- STM.newTQueueIO-        toServer <- STM.newTQueueIO-        return $! ChanServer{..}-      mkChanFrontend :: IO Frontend.ChanFrontend-      mkChanFrontend = STM.newTQueueIO-      addConn :: FactionId -> Faction -> IO ConnServerFaction-      addConn fid fact = case EM.lookup fid oldD of-        Just conns -> return conns  -- share old conns and threads-        Nothing | playerUI $ gplayer fact -> do-          connF <- mkChanFrontend-          connS <- mkChanServer-          connAI <- mkChanServer-          return (Just (connF, connS), connAI)-        Nothing -> do-          connAI <- mkChanServer-          return (Nothing, connAI)-  factionD <- getsState sfactionD-  d <- liftIO $ mapWithKeyM addConn factionD-  let newD = d `EM.union` oldD  -- never kill old clients-  putDict newD-  -- Spawn client threads.-  let toSpawn = newD EM.\\ oldD-      fdict fid = ( fst-                    $ fromMaybe (assert `failure` "no channel" `twith` fid)-                    $ fst-                    $ fromMaybe (assert `failure` "no faction" `twith` fid)-                    $ EM.lookup fid newD-                  , maybe T.empty gname  -- a faction can go inactive-                    $ EM.lookup fid factionD-                  )-      fromM = Frontend.fromMulti Frontend.connMulti-  liftIO $ void $ takeMVar fromM  -- stop Frontend-  let forkUI fid (connF, connS) =-        void $ forkChild childrenServer $ executorUI fid connF connS-      forkAI fid connS =-        void $ forkChild childrenServer $ executorAI fid connS-      forkClient fid (connUI, connAI) = do-        -- When a connection is reused, clients are not respawned,-        -- 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-  liftIO $ mapWithKeyM_ forkClient toSpawn-  nU <- nUI-  liftIO $ putMVar fromM (nU, fdict)  -- restart Frontend--killAllClients :: (MonadAtomic m, MonadConnServer m) => m ()-killAllClients = do-  d <- getDict-  let sendKill fid _ = do-        -- We can't check in sfactionD, because client can be from an old game.-        when (fromEnum fid > 0) $-          sendUpdateUI fid $ CmdAtomicUI $ KillExitA fid-        sendUpdateAI fid $ CmdAtomicAI $ KillExitA fid-  mapWithKeyM_ sendKill d---- | Compute and insert auxiliary optimized components into game content,--- to be used in time-critical sections of the code.-speedupCOps :: Bool -> Kind.COps -> Kind.COps-speedupCOps allClear copsSlow@Kind.COps{cotile=tile} =-  let ospeedup = Tile.speedup allClear tile-      cotile = tile {Kind.ospeedup = Just ospeedup}-  in copsSlow {Kind.cotile = cotile}---- | Invoke pseudo-random computation with the generator kept in the state.-rndToAction :: MonadServer m => Rnd a -> m a-rndToAction r = do-  g <- getsServer srandom-  let (a, ng) = St.runState r g-  modifyServer $ \ser -> ser {srandom = ng}-  return $! a---- | Gets a random generator from the arguments or, if not present,--- generates one.-getSetGen :: MonadServer m-          => Maybe R.StdGen-          -> m R.StdGen-getSetGen mrng = case mrng of-  Just rnd -> return rnd-  Nothing -> liftIO $ R.newStdGen
− Game/LambdaHack/Server/Action/ActionClass.hs 
@@ -1,27 +0,0 @@--- | Basic type classes for server game actions.--- This module should not be imported anywhere except in 'Action'--- and 'TypeAction'.-module Game.LambdaHack.Server.Action.ActionClass where--import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.ClientCmd-import Game.LambdaHack.Server.State--class MonadActionRO m => MonadServer m where-  getServer    :: m StateServer-  getsServer   :: (StateServer -> a) -> m a-  modifyServer :: (StateServer -> StateServer) -> m ()-  putServer    :: StateServer -> m ()-  -- We do not provide a MonadIO instance, so that outside of Action/-  -- nobody can subvert the action monads by invoking arbitrary IO.-  liftIO       :: IO a -> m a-  saveServer   :: m ()--class MonadServer m => MonadConnServer m where-  getDict      :: m ConnServerDict-  getsDict     :: (ConnServerDict -> a) -> m a-  modifyDict   :: (ConnServerDict -> ConnServerDict) -> m ()-  putDict      :: ConnServerDict -> m ()--saveName :: String-saveName = serverSaveName
− Game/LambdaHack/Server/Action/ActionType.hs 
@@ -1,85 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- | The main game action monad type implementation. Just as any other--- component of the library, this implementation can be substituted.--- This module should not be imported anywhere except in 'Action'--- to expose the executor to any code using the library.-module Game.LambdaHack.Server.Action.ActionType-  ( ActionSer, executorSer-  ) where--import Control.Applicative-import qualified Control.Monad.IO.Class as IO-import Control.Monad.Trans.State.Strict hiding (State)-import qualified Data.EnumMap.Strict as EM-import Data.Maybe-import System.FilePath--import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.ClientCmd-import qualified Game.LambdaHack.Common.Save as Save-import Game.LambdaHack.Common.State-import Game.LambdaHack.Server.Action.ActionClass-import Game.LambdaHack.Server.State--data SerState = SerState-  { serState  :: !State           -- ^ current global state-  , serServer :: !StateServer     -- ^ current server state-  , serDict   :: !ConnServerDict  -- ^ client-server connection information-  , serToSave :: !(Save.ChanSave (State, StateServer))-                                  -- ^ connection to the save thread-  }---- | Server state transformation monad.-newtype ActionSer a = ActionSer {runActionSer :: StateT SerState IO a}-  deriving (Monad, Functor, Applicative)--instance MonadActionRO ActionSer where-  getState    = ActionSer $ gets serState-  getsState f = ActionSer $ gets $ f . serState--instance MonadAction ActionSer where-  modifyState f = ActionSer $ state $ \serS ->-    let newSerS = serS {serState = f $ serState serS}-    in newSerS `seq` ((), newSerS)-  putState    s = ActionSer $ state $ \serS ->-    let newSerS = serS {serState = s}-    in newSerS `seq` ((), newSerS)--instance MonadServer ActionSer where-  getServer      = ActionSer $ gets serServer-  getsServer   f = ActionSer $ gets $ f . serServer-  modifyServer f = ActionSer $ state $ \serS ->-    let newSerS = serS {serServer = f $ serServer serS}-    in newSerS `seq` ((), newSerS)-  putServer    s = ActionSer $ state $ \serS ->-    let newSerS = serS {serServer = s}-    in newSerS `seq` ((), newSerS)-  liftIO         = ActionSer . IO.liftIO-  saveServer     = ActionSer $ do-    s <- gets serState-    ser <- gets serServer-    toSave <- gets serToSave-    IO.liftIO $ Save.saveToChan toSave (s, ser)--instance MonadConnServer ActionSer where-  getDict      = ActionSer $ gets serDict-  getsDict   f = ActionSer $ gets $ f . serDict-  modifyDict f =-    ActionSer $ modify $ \serS -> serS {serDict = f $ serDict serS}-  putDict    s =-    ActionSer $ modify $ \serS -> serS {serDict = s}---- | Run an action in the @IO@ monad, with undefined state.-executorSer :: ActionSer () -> IO ()-executorSer m =-  let saveFile (_, ser) =-        fromMaybe "save" (ssavePrefixSer (sdebugSer ser))-        <.> saveName-      exe serToSave =-        evalStateT (runActionSer m)-          SerState { serState = emptyState-                   , serServer = emptyStateServer-                   , serDict = EM.empty-                   , serToSave-                   }-  in Save.wrapInSaves saveFile exe
− Game/LambdaHack/Server/AtomicSemSer.hs 
@@ -1,176 +0,0 @@--- | Sending atomic commands to clients and executing them on the server.--- See--- <https://github.com/kosmikus/LambdaHack/wiki/Client-server-architecture>.-module Game.LambdaHack.Server.AtomicSemSer-  ( atomicSendSem-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Key (mapWithKeyM_)-import Data.Maybe--import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.AtomicCmd-import Game.LambdaHack.Common.AtomicPos-import Game.LambdaHack.Common.AtomicSem-import Game.LambdaHack.Common.ClientCmd-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Server.Action-import Game.LambdaHack.Server.State--storeUndo :: MonadServer m => Atomic -> m ()-storeUndo _atomic =-  maybe skip (\a -> modifyServer $ \ser -> ser {sundo = a : sundo ser})-    $ Nothing   -- TODO: undoAtomic atomic--atomicServerSem :: (MonadAction m, MonadServer m)-                => PosAtomic -> Atomic -> m ()-atomicServerSem posAtomic atomic =-  when (seenAtomicSer posAtomic) $ do-    storeUndo atomic-    case atomic of-      CmdAtomic cmd -> cmdAtomicSem cmd-      SfxAtomic _ -> return ()---- | Send an atomic action to all clients that can see it.-atomicSendSem :: (MonadAction m, MonadConnServer m) => Atomic -> m ()-atomicSendSem atomic = do-  -- Gather data from the old state.-  sOld <- getState-  factionD <- getsState sfactionD-  persOld <- getsServer sper-  (ps, resets, atomicBroken, psBroken) <--    case atomic of-      CmdAtomic cmd -> do-        ps <- posCmdAtomic cmd-        resets <- resetsFovAtomic cmd-        atomicBroken <- breakCmdAtomic cmd-        psBroken <- mapM posCmdAtomic atomicBroken-        return (ps, resets, atomicBroken, psBroken)-      SfxAtomic sfx -> do-        ps <- posSfxAtomic sfx-        return (ps, Just [], [], [])-  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-            _ -> resets == Just []-                 && (null atomicBroken-                     || fmap CmdAtomic atomicBroken == [atomic])) skip-  -- Perform the action on the server.-  atomicServerSem ps atomic-  -- Send some actions to the clients, one faction at a time.-  knowEvents <- getsServer $ sknowEvents . sdebugSer-  let sendUI fid cmdUI =-        when (playerUI $ gplayer $ factionD EM.! fid) $ sendUpdateUI fid cmdUI-      sendAI fid cmdAI = sendUpdateAI fid cmdAI-      sendA fid cmd = do-        sendUI fid $ CmdAtomicUI cmd-        sendAI fid $ CmdAtomicAI cmd-      sendUpdate fid (CmdAtomic cmd) = sendA fid cmd-      sendUpdate fid (SfxAtomic sfx) = sendUI fid $ SfxAtomicUI sfx-      breakSend fid perNew = do-        let send2 (atomic2, ps2) =-              if seenAtomicCli knowEvents fid perNew ps2-                then sendUpdate fid $ CmdAtomic atomic2-                else when (loudCmdAtomic fid atomic2) $-                       sendUpdate fid-                       $ SfxAtomic $ MsgAllD "You hear some noises."-        mapM_ send2 atomicPsBroken-      anySend fid perOld perNew = do-        let startSeen = seenAtomicCli knowEvents fid perOld ps-            endSeen = seenAtomicCli knowEvents fid perNew ps-        if startSeen && endSeen-          then sendUpdate fid atomic-          else breakSend fid perNew-      posLevel fid lid = do-        let perOld = persOld EM.! fid EM.! lid-            resetsFid = maybe True (fid `elem`) resets-        if resetsFid then do-          resetFidPerception fid lid-          perNew <- getPerFid fid lid-          let inPer = diffPer perNew perOld-              outPer = diffPer perOld perNew-          if nullPer outPer && nullPer inPer-            then anySend fid perOld perOld-            else do-              unless knowEvents $ do  -- inconsistencies would quickly manifest-                sendA fid $ PerceptionA lid outPer inPer-                let remember = atomicRemember lid inPer sOld-                    seenNew = seenAtomicCli False fid perNew-                    seenOld = seenAtomicCli False fid perOld-                -- TODO: these assertions are probably expensive-                psRem <- mapM posCmdAtomic remember-                -- Verify that we remember only currently seen things.-                assert (allB seenNew psRem) skip-                -- Verify that we remember only new things.-                assert (allB (not . seenOld) psRem) skip-                mapM_ (sendA fid) remember-              anySend fid perOld perNew-        else anySend fid perOld perOld-      send fid = case ps of-        PosSight lid _ -> posLevel fid lid-        PosFidAndSight _ lid _ -> posLevel fid lid-        -- In the following cases, from the assertion above,-        -- @resets@ is false here and broken atomic has the same ps.-        PosSmell lid _ -> do-          let perOld = persOld EM.! fid EM.! lid-          anySend fid perOld perOld-        PosFid fid2 -> when (fid == fid2) $ sendUpdate fid atomic-        PosFidAndSer fid2 -> when (fid == fid2) $ sendUpdate fid atomic-        PosSer -> return ()-        PosAll -> sendUpdate fid atomic-        PosNone -> assert `failure` "illegal sending" `twith` (atomic, fid)-  mapWithKeyM_ (\fid _ -> send fid) factionD--atomicRemember :: LevelId -> Perception -> State -> [CmdAtomic]-atomicRemember lid inPer s =-  -- No @LoseItemA@ is sent for items that became out of sight.-  -- The client will create these atomic actions based on @outPer@,-  -- if required. Any client that remembers out of sight items, OTOH,-  -- will create atomic actions that forget remembered items-  -- that are revealed not to be there any more (no @SpotItemA@ for them).-  -- Similarly no @LoseActorA@, @LoseTileA@ nor @LoseSmellA@.-  let inFov = ES.elems $ totalVisible inPer-      lvl = sdungeon s EM.! lid-      -- Actors.-      inPrio = concatMap (\p -> posToActors p lid s) inFov-      fActor ((aid, b), ais) = SpotActorA aid b ais-      inActor = map fActor inPrio-      -- Items.-      pMaybe p = maybe Nothing (\x -> Just (p, x))-      inFloor = mapMaybe (\p -> pMaybe p $ EM.lookup p (lfloor lvl)) inFov-      fItem p (iid, k) = SpotItemA iid (getItemBody iid s) k (CFloor lid p)-      fBag (p, bag) = map (fItem p) $ EM.assocs bag-      inItem = concatMap fBag inFloor-      -- Tiles.-      cotile = Kind.cotile (scops s)-      inTileMap = map (\p -> (p, hideTile cotile lvl p)) inFov-      atomicTile = if null inTileMap then [] else [SpotTileA lid inTileMap]-      -- TODO: somehow also use this-      -- bonus = case strongestSearch itemAssocs of-      --          Just (k, _)  -> k + 1-      --          Nothing -> 1-      -- TODO: add 'search' that rescans FOV, perhaps with a bonus-      -- TODO: add 'explore' that tells a tile is a hidden door, etc.-      -- TODO: when explored tile is boring, display tips, monster scratches,-      -- old inscriptions and other flavour, as in UnAngband-      -- TODO: make floor paths from hidden tiles-      -- TODO: perhaps decrease secrecy as lseen, ltime or lsmell increases-      -- or a per-party counter increases-      -- Smells.-      inSmellFov = ES.elems $ smellVisible inPer-      inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl)) inSmellFov-      atomicSmell = if null inSm then [] else [SpotSmellA lid inSm]-  in inItem ++ inActor ++ atomicTile ++ atomicSmell
+ Game/LambdaHack/Server/Commandline.hs view
@@ -0,0 +1,117 @@+-- | Parsing of commandline arguments.+module Game.LambdaHack.Server.Commandline+  ( debugArgs+  ) where++import qualified Data.Text as T++import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Server.State++-- TODO: make more maintainable++debugArgs :: [String] -> IO DebugModeSer+debugArgs args = do+  let usage =+        [ "Configure debug options here, gameplay options in config.rules.ini."+        , "  --knowMap  reveal map for all clients in the next game"+        , "  --knowEvents  show all events in the next game (needs --knowMap)"+        , "  --sniffIn  display all incoming commands on console "+        , "  --sniffOut  display all outgoing commands on console "+        , "  --allClear  let all map tiles be translucent"+        , "  --gameMode m  start next game in the given mode"+        , "  --automateAll  give control of all UI teams to computer"+        , "  --newGame  start a new game, overwriting the save file"+        , "  --difficulty n  set difficulty for all UI players to n"+        , "  --stopAfter n  exit this game session after around n seconds"+        , "  --benchmark  print stats, limit saving and other file operations"+        , "  --setDungeonRng s  set dungeon generation RNG seed to string s"+        , "  --setMainRng s  set the main game RNG seed to string s"+        , "  --dumpInitRngs  dump RNG states from the start of the game"+        , "  --dbgMsgSer  let the server emit its internal debug messages"+        , "  --font fn  use the given font for the main game window"+        , "  --maxFps n  display at most n frames per second"+        , "  --noDelay  don't maintain any requested delays between frames"+        , "  --noMore  auto-answer all prompts"+        , "  --noAnim  don't show any animations"+        , "  --savePrefix  prepend the text to all savefile names"+        , "  --frontendStd  use the simple stdout/stdin frontend"+        , "  --frontendNull  use no frontend at all (for AIvsAI benchmarks)"+        , "  --dbgMsgCli  let clients emit their internal debug messages"+        , "  --fovMode m  set a Field of View mode, where m can be"+        , "    Digital"+        , "    Permissive"+        , "    Shadow"+        , "    Blind"+        ]+      parseArgs [] = defDebugModeSer+      parseArgs ("--knowMap" : rest) =+        (parseArgs rest) {sknowMap = True}+      parseArgs ("--knowEvents" : rest) =+        (parseArgs rest) {sknowEvents = True}+      parseArgs ("--sniffIn" : rest) =+        (parseArgs rest) {sniffIn = True}+      parseArgs ("--sniffOut" : rest) =+        (parseArgs rest) {sniffOut = True}+      parseArgs ("--allClear" : rest) =+        (parseArgs rest) {sallClear = True}+      parseArgs ("--gameMode" : s : rest) =+        (parseArgs rest) {sgameMode = T.pack s}+      parseArgs ("--automateAll" : rest) =+        (parseArgs rest) {sautomateAll = True}+      parseArgs ("--newGame" : rest) =+        let debugSer = parseArgs rest+        in debugSer { snewGameSer = True+                    , sdebugCli = (sdebugCli debugSer) {snewGameCli = True}}+      parseArgs ("--difficulty" : s : rest) =+        let debugSer = parseArgs rest+            diff = read s+        in debugSer { sdifficultySer = diff+                    , sdebugCli = (sdebugCli debugSer) {sdifficultyCli = diff}}+      parseArgs ("--stopAfter" : s : rest) =+        (parseArgs rest) {sstopAfter = Just $ read s}+      parseArgs ("--benchmark" : rest) =+        (parseArgs rest) {sbenchmark = True}+      parseArgs ("--setDungeonRng" : s : rest) =+        (parseArgs rest) {sdungeonRng = Just $ read s}+      parseArgs ("--setMainRng" : s : rest) =+        (parseArgs rest) {smainRng = Just $ read s}+      parseArgs ("--dumpInitRngs" : rest) =+        (parseArgs rest) {sdumpInitRngs = True}+      parseArgs ("--fovMode" : mode : rest) =+        (parseArgs rest) {sfovMode = Just $ read mode}+      parseArgs ("--dbgMsgSer" : rest) =+        (parseArgs rest) {sdbgMsgSer = True}+      parseArgs ("--font" : s : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {sfont = Just s}}+      parseArgs ("--maxFps" : n : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli =+                       (sdebugCli debugSer) {smaxFps = Just $ max 1 $ read n}}+      parseArgs ("--noDelay" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {snoDelay = True}}+      parseArgs ("--noMore" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {snoMore = True}}+      parseArgs ("--noAnim" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {snoAnim = Just True}}+      parseArgs ("--savePrefix" : s : rest) =+        let debugSer = parseArgs rest+        in debugSer { ssavePrefixSer = Just s+                    , sdebugCli =+                        (sdebugCli debugSer) {ssavePrefixCli = Just s}}+      parseArgs ("--frontendStd" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendStd = True}}+      parseArgs ("--frontendNull" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {sfrontendNull = True}}+      parseArgs ("--dbgMsgCli" : rest) =+        let debugSer = parseArgs rest+        in debugSer {sdebugCli = (sdebugCli debugSer) {sdbgMsgCli = True}}+      parseArgs (wrong : _rest) =+        error $ "Unrecognized: " ++ wrong ++ "\n" ++ unlines usage+  return $! parseArgs args
+ Game/LambdaHack/Server/CommonServer.hs view
@@ -0,0 +1,405 @@+{-# LANGUAGE TupleSections #-}+-- | Server operations common to many modules.+module Game.LambdaHack.Server.CommonServer+  ( execFailure, resetFidPerception, resetLitInDungeon, getPerFid+  , revealItems, moveStores, deduceQuits, deduceKilled, electLeader+  , addActor, addActorIid, projectFail, pickWeaponServer, sumOrganEqpServer+  , actorSkillsServer+  ) where++import Control.Applicative+import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+import Data.Int (Int64)+import Data.List+import Data.Maybe+import Data.Text (Text)+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Atomic+import qualified Game.LambdaHack.Common.Ability as Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Color as Color+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Flavour+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.Random+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.Content.ItemKind+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Server.Fov+import Game.LambdaHack.Server.ItemServer+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++execFailure :: (MonadAtomic m, MonadServer m)+            => ActorId -> RequestTimed a -> ReqFailure -> m ()+execFailure aid req failureSer = do+  -- Clients should rarely do that (only in case of invisible actors)+  -- so we report it, send a --more-- meeesage (if not AI), but do not crash+  -- (server should work OK with stupid clients, too).+  body <- getsState $ getActorBody aid+  let fid = bfid body+      msg = showReqFailure failureSer+  debugPrint $ "execFailure:" <+> msg <> "\n"+               <> tshow body <> "\n" <> tshow req+  execSfxAtomic $ SfxMsgFid fid $ "Unexpected problem:" <+> msg <> "."+    -- TODO: --more--, but keep in history++-- | Update the cached perception for the selected level, for a faction.+-- The assumption is the level, and only the level, has changed since+-- the previous perception calculation.+resetFidPerception :: MonadServer m+                   => 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+      upd = EM.adjust (EM.adjust (const per) lid) fid+  modifyServer $ \ser2 -> ser2 {sper = upd (sper ser2)}+  return $! per++resetLitInDungeon :: MonadServer m => m PersLit+resetLitInDungeon = do+  sfovMode <- getsServer $ sfovMode . sdebugSer+  ser <- getServer+  let fovMode = fromMaybe Digital sfovMode+  getsState $ \s -> litInDungeon fovMode s ser++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+  return $! per++revealItems :: (MonadAtomic m, MonadServer m)+            => Maybe FactionId -> Maybe Actor -> m ()+revealItems mfid mbody = do+  itemToF <- itemToFullServer+  dungeon <- getsState sdungeon+  let discover b iid k =+        let itemFull = itemToF iid k+        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)+      f aid = do+        b <- getsState $ getActorBody aid+        let ourSide = maybe True (== bfid b) mfid+        when (ourSide && Just b /= mbody) $ mapActorItems_ (discover b) b+  mapDungeonActors_ f dungeon+  maybe skip (\b -> mapActorItems_ (discover b) b) mbody++moveStores :: (MonadAtomic m, MonadServer m)+           => ActorId -> CStore -> CStore -> m ()+moveStores aid fromStore toStore = do+  b <- getsState $ getActorBody aid+  let g iid k = execUpdAtomic $ UpdMoveItem iid k aid fromStore toStore+  mapActorCStore_ fromStore g b++quitF :: (MonadAtomic m, MonadServer m)+      => Maybe Actor -> Status -> FactionId -> m ()+quitF mbody status fid = do+  assert (maybe True ((fid ==) . bfid) mbody) skip+  fact <- getsState $ (EM.! fid) . sfactionD+  let oldSt = gquit fact+  case fmap 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 (playerUI $ gplayer fact) $ do+        revealItems (Just fid) mbody+        registerScore status mbody fid+      execUpdAtomic $ UpdQuitFaction fid mbody oldSt $ Just status+      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}+  | 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+        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+      assocsKeepArena = filter (keepArenaFact . snd) assocsInGame+      assocsUI = filter (playerUI . gplayer . snd) assocsInGame+      worldPeace =+        all (\(fid1, _) -> all (\(_, fact2) -> not $ isAtWar fact2 fid1)+                           assocsInGame)+        assocsInGame+  case assocsKeepArena of+    _ | null assocsUI ->+      -- Only non-UI players left in the game and they all win.+      mapQuitF status{stOutcome=Conquer} keysInGame+    [] ->+      -- Only leaderless and spawners remain (the latter may sometimes+      -- have no leader, just as the former), so they win,+      -- or we could end up in a state with no active arena.+      mapQuitF status{stOutcome=Conquer} keysInGame+    _ | worldPeace ->+      -- Nobody is at war any more, so all win (e.g., horrors, but never mind).+      mapQuitF status{stOutcome=Conquer} keysInGame+    _ | 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+      mapQuitF status{stOutcome=Escape} $ map fst victors+      mapQuitF status{stOutcome=Defeated} $ map fst losers+    _ -> return ()++deduceKilled :: (MonadAtomic m, MonadServer m) => Actor -> m ()+deduceKilled body = do+  Kind.COps{corule} <- getsState scops+  let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule+      fid = bfid body+  fact <- getsState $ (EM.! fid) . sfactionD+  unless (isSpawnFact fact) $ do  -- spawners never die off+    actorsAlive <- anyActorsAlive fid+    when (not actorsAlive || firstDeathEnds) $+      deduceQuits body $ Status Killed (fromEnum $ blid body) ""++anyActorsAlive :: MonadServer m => FactionId -> m Bool+anyActorsAlive fid = do+  fact <- getsState $ (EM.! fid) . sfactionD+  if playerLeader (gplayer fact)+    then return $! isJust $ gleader fact+    else do+      as <- getsState $ fidActorNotProjList fid+      return $! not $ null as++electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m ()+electLeader fid lid aidDead = do+  mleader <- getsState $ gleader . (EM.! fid) . sfactionD+  when (isNothing mleader || mleader == Just aidDead) $ do+    actorD <- getsState sactorD+    let ours (_, b) = bfid b == fid && not (bproj b)+        party = filter ours $ EM.assocs actorD+    onLevel <- getsState $ actorRegularAssocs (== fid) lid+    let mleaderNew = listToMaybe $ filter (/= aidDead)+                     $ map fst $ onLevel ++ party+    unless (mleader == mleaderNew) $+      execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew++projectFail :: (MonadAtomic m, MonadServer m)+            => ActorId    -- ^ actor projecting the item (is on current lvl)+            -> Point      -- ^ target position of the projectile+            -> Int        -- ^ digital line parameter+            -> ItemId     -- ^ the item to be projected+            -> CStore     -- ^ whether the items comes from floor or inventory+            -> Bool       -- ^ whether the item is a shrapnel+            -> m (Maybe ReqFailure)+projectFail source tpxy eps iid cstore isShrapnel = do+  Kind.COps{cotile} <- getsState scops+  sb <- getsState $ getActorBody source+  let lid = blid sb+      spos = bpos sb+  lvl@Level{lxsize, lysize} <- getLevel lid+  case bla lxsize lysize eps spos tpxy of+    Nothing -> return $ Just ProjectAimOnself+    Just [] -> assert `failure` "projecting from the edge of level"+                      `twith` (spos, tpxy)+    Just (pos : restUnlimited) -> do+      item <- getsState $ getItemBody iid+      let fragile = Effect.Fragile `elem` jfeature item+          rest = if fragile+                 then take (chessDist spos tpxy - 1) restUnlimited+                 else restUnlimited+          t = lvl `at` pos+      if not $ Tile.isWalkable cotile t+        then return $ Just ProjectBlockTerrain+        else do+          mab <- getsState $ posToActor pos lid+          actorBlind <- radiusBlind+                        <$> sumOrganEqpServer Effect.EqpSlotAddSight source+          if not $ maybe True (bproj . snd . fst) mab+            then if isShrapnel && bproj sb then do+                   -- Hit the blocking actor.+                   projectBla source spos (pos:rest) iid cstore isShrapnel+                   return Nothing+                 else return $ Just ProjectBlockActor+            else if actorBlind && not (isShrapnel || bproj sb) then+                   return $ Just ProjectBlind+                 else do+                   if isShrapnel && bproj sb && eps `mod` 2 == 0 then+                     -- Make the explosion a bit less regular.+                     projectBla source spos (pos:rest) iid cstore isShrapnel+                   else+                     projectBla source pos rest iid cstore isShrapnel+                   return Nothing++projectBla :: (MonadAtomic m, MonadServer m)+           => ActorId    -- ^ actor projecting the item (is on current lvl)+           -> Point      -- ^ starting point of the projectile+           -> [Point]    -- ^ rest of the trajectory of the projectile+           -> ItemId     -- ^ the item to be projected+           -> CStore     -- ^ whether the items comes from floor or inventory+           -> Bool       -- ^ whether the item is a shrapnel+           -> m ()+projectBla source pos rest iid cstore isShrapnel = do+  sb <- getsState $ getActorBody source+  item <- getsState $ getItemBody iid+  let lid = blid sb+  localTime <- getsState $ getLocalTime lid+  unless isShrapnel $ execSfxAtomic $ SfxProject source iid+  addProjectile pos rest iid lid (bfid sb) localTime isShrapnel+  let c = CActor source cstore+  execUpdAtomic $ UpdLoseItem iid item 1 c++-- | Create a projectile actor containing the given missile.+--+-- Projectile has no organs except for the trunk.+addProjectile :: (MonadAtomic m, MonadServer m)+              => Point -> [Point] -> ItemId -> LevelId -> FactionId+              -> Time -> Bool+              -> m ()+addProjectile bpos rest iid blid bfid btime isShrapnel = do+  itemToF <- itemToFullServer+  let itemFull@ItemFull{itemBase} = itemToF iid 1+      (trajectory, (speed, trange)) = itemTrajectory itemBase (bpos : rest)+      adj | trange < 5 = "falling"+          | otherwise = "flying"+      -- Not much detail about a fast flying item.+      (object1, object2) = partItem CInv $ itemNoDisco (itemBase, 1)+      bname = makePhrase [MU.AW $ MU.Text adj, object1, object2]+      tweakBody b = b { bsymbol = if isShrapnel then bsymbol b else '*'+                      , bcolor = if isShrapnel then bcolor b else Color.BrWhite+                      , bname+                      , bhp = 0+                      , bproj = True+                      , btrajectory = Just (trajectory, speed)+                      , beqp = EM.singleton iid 1+                      , borgan = EM.empty}+      bpronoun = "it"+  void $ addActorIid iid itemFull+                     bfid bpos blid tweakBody bpronoun btime++addActor :: (MonadAtomic m, MonadServer m)+         => Text -> FactionId -> Point -> LevelId+         -> (Actor -> Actor) -> Text -> Time+         -> m (Maybe ActorId)+addActor actorGroup bfid pos lid tweakBody bpronoun time = do+  -- We bootstrap the actor by first creating the trunk of the actor's body+  -- contains the constant properties.+  let trunkFreq = [(actorGroup, 1)]+  m2 <- rollAndRegisterItem lid trunkFreq (CTrunk bfid lid pos) False+  case m2 of+    Nothing -> return Nothing+    Just (trunkId, (trunkFull, _)) ->+      addActorIid trunkId trunkFull bfid pos lid tweakBody bpronoun time++addActorIid :: (MonadAtomic m, MonadServer m)+            => ItemId -> ItemFull -> FactionId -> Point -> LevelId+            -> (Actor -> Actor) -> Text -> Time+            -> m (Maybe ActorId)+addActorIid trunkId trunkFull@ItemFull{..}+            bfid pos lid tweakBody bpronoun time = do+  let trunkKind = case itemDisco of+        Just ItemDisco{itemKind} -> itemKind+        Nothing -> assert `failure` trunkFull+  -- Initial HP and Calm is based only on trunk and ignores organs.+  let hp = xM (max 2 $ sumSlotNoFilter Effect.EqpSlotAddMaxHP [trunkFull])+           `div` 2+      calm = xM $ max 1+             $ sumSlotNoFilter Effect.EqpSlotAddMaxCalm [trunkFull]+  -- Create actor.+  fact@Faction{gplayer} <- getsState $ (EM.! bfid) . sfactionD+  DebugModeSer{sdifficultySer} <- getsServer sdebugSer+  nU <- nUI+  -- If no UI factions, the difficulty applies to heroes (for testing).+  let diffHP | playerUI gplayer || nU == 0 && isHeroFact fact =+        (ceiling :: Double -> Int64)+        $ fromIntegral hp+          * 1.5 ^^ difficultyCoeff sdifficultySer+             | otherwise = hp+      bsymbol = jsymbol itemBase+      bname = jname itemBase+      bcolor = flavourToColor $ jflavour itemBase+      b = actorTemplate trunkId bsymbol bname bpronoun bcolor diffHP calm+                        pos lid time bfid+      -- Insert the trunk as the actor's organ.+      withTrunk = b {borgan = EM.singleton trunkId itemK}+  aid <- getsServer sacounter+  modifyServer $ \ser -> ser {sacounter = succ aid}+  execUpdAtomic $ UpdCreateActor aid (tweakBody withTrunk) [(trunkId, itemBase)]+  -- Create, register and insert all initial actor items.+  forM_ (ikit trunkKind) $ \(ikText, cstore) -> do+    let container = CActor aid cstore+        itemFreq = [(ikText, 1)]+    void $ rollAndRegisterItem lid itemFreq container False+  return $ Just aid++-- Server has to pick a random weapon or it could leak item discovery+-- information. In case of non-projectiles, it only picks items+-- with some effects, though, so it leaks properties of completely+-- unidentified items.+pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore))+pickWeaponServer source = do+  sb <- getsState $ getActorBody source+  eqpAssocs <- fullAssocsServer source [CEqp]+  bodyAssocs <- fullAssocsServer source [COrgan]+  -- 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+      strongest | bproj sb = map (1,) eqpAssocs+                | otherwise =+                    strongestSlotNoFilter Effect.EqpSlotWeapon allAssocs+  case strongest 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+      let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp+      return $ Just (iid, cstore)++sumOrganEqpServer :: MonadServer m+                 => Effect.EqpSlot -> ActorId -> m Int+sumOrganEqpServer eqpSlot aid = do+  activeAssocs <- activeItemsServer aid+  return $! sumSlotNoFilter eqpSlot activeAssocs++actorSkillsServer :: MonadServer m+                  => ActorId -> Maybe ActorId -> m Ability.Skills+actorSkillsServer aid mleader = do+  activeItems <- activeItemsServer aid+  getsState $ actorSkills aid mleader activeItems
+ Game/LambdaHack/Server/DebugServer.hs view
@@ -0,0 +1,92 @@+-- | Debug output for requests and responseQs.+module Game.LambdaHack.Server.DebugServer+  ( debugResponseAI, debugResponseUI+  , debugRequestAI, debugRequestUI+  ) where++import Data.Text (Text)+import qualified Data.Text as T++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.Response+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Server.MonadServer++-- We debug these on the server, not on the clients, because we want+-- a single log, knowing the order in which the server received requests+-- and sent responseQs. Clients interleave and block non-deterministically+-- so their logs would be harder to interpret.++debugResponseAI :: MonadServer m => ResponseAI -> m ()+debugResponseAI cmd = case cmd of+  RespUpdAtomicAI cmdA@UpdPerception{} -> debugPlain cmd cmdA+  RespUpdAtomicAI cmdA@UpdResume{} -> debugPlain cmd cmdA+  RespUpdAtomicAI cmdA@UpdSpotTile{} -> debugPlain cmd cmdA+  RespUpdAtomicAI cmdA -> debugPretty cmd cmdA+  RespQueryAI aid -> do+    d <- debugAid aid "RespQueryAI" cmd+    debugPrint d+  RespPingAI -> debugPrint $ tshow cmd++debugResponseUI :: MonadServer m => ResponseUI -> m ()+debugResponseUI cmd = case cmd of+  RespUpdAtomicUI cmdA@UpdPerception{} -> debugPlain cmd cmdA+  RespUpdAtomicUI cmdA@UpdResume{} -> debugPlain cmd cmdA+  RespUpdAtomicUI cmdA@UpdSpotTile{} -> debugPlain cmd cmdA+  RespUpdAtomicUI cmdA -> debugPretty cmd cmdA+  RespSfxAtomicUI sfx -> do+    ps <- posSfxAtomic sfx+    debugPrint $ tshow (cmd, ps)+  RespQueryUI -> debugPrint $ "RespQueryUI:" <+> tshow cmd+  RespPingUI -> debugPrint $ tshow cmd++debugPretty :: (MonadServer m, Show a) => a -> UpdAtomic -> m ()+debugPretty cmd cmdA = do+  ps <- posUpdAtomic cmdA+  debugPrint $ tshow (cmd, ps)++debugPlain :: (MonadServer m, Show a) => a -> UpdAtomic -> m ()+debugPlain cmd cmdA = do+  ps <- posUpdAtomic cmdA+  debugPrint $ T.pack $ show (cmd, ps)  -- too large for pretty show++debugRequestAI :: MonadServer m => ActorId -> RequestAI -> m ()+debugRequestAI aid cmd = do+  d <- debugAid aid "AI request" cmd+  debugPrint d++debugRequestUI :: MonadServer m => ActorId -> RequestUI -> m ()+debugRequestUI aid cmd = do+  d <- debugAid aid "UI request" cmd+  debugPrint d++data DebugAid a = DebugAid+  { label   :: !Text+  , cmd     :: !a+  , lid     :: !LevelId+  , time    :: !Time+  , aid     :: !ActorId+  , faction :: !FactionId+  }+  deriving Show++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+  else do+    b <- getsState $ getActorBody aid+    time <- getsState $ getLocalTime (blid b)+    return $! tshow DebugAid { label+                             , cmd+                             , lid = blid b+                             , time+                             , aid+                             , faction = bfid b }
Game/LambdaHack/Server/DungeonGen.hs view
@@ -1,11 +1,15 @@--- | The main dungeon generation routine.+-- | The unpopulated dungeon generation routine. module Game.LambdaHack.Server.DungeonGen-  ( FreshDungeon(..), dungeonGen+  ( -- * Public API+    FreshDungeon(..), dungeonGen+    -- * Internal functions+  , convertTileMaps, placeStairs, buildLevel, levelFromCaveKind, findGenerator   ) where  import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM+import qualified Data.IntMap.Strict as IM import Data.List import Data.Maybe import Data.Text (Text)@@ -14,6 +18,7 @@ import qualified Game.LambdaHack.Common.Feature as F import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray import Game.LambdaHack.Common.Random@@ -25,36 +30,83 @@ import Game.LambdaHack.Server.DungeonGen.Area import Game.LambdaHack.Server.DungeonGen.Cave import Game.LambdaHack.Server.DungeonGen.Place-import Game.LambdaHack.Utils.Frequency -convertTileMaps :: Rnd (Kind.Id TileKind) -> Int -> Int -> TileMapEM+convertTileMaps :: Kind.Ops TileKind+                -> Rnd (Kind.Id TileKind) -> Maybe (Rnd (Kind.Id TileKind))+                -> Int -> Int -> TileMapEM                 -> Rnd TileMap-convertTileMaps cdefTile cxsize cysize ltile = do+convertTileMaps cotile cdefTile mcdefTileWalkable cxsize cysize ltile = do   let f :: Point -> Rnd (Kind.Id TileKind)       f p = case EM.lookup p ltile of         Just t -> return t         Nothing -> cdefTile-  PointArray.generateMA cxsize cysize f+  converted1 <- PointArray.generateMA cxsize cysize f+  case mcdefTileWalkable of+    Nothing -> return converted1  -- no walkable tiles for filling the map+    Just cdefTileWalkable -> do  -- some tiles walkable, so ensure connectivity+      -- TODO: perhaps checking connectivity with BFS would be better,+      -- but it's still artibrary how we recover connectivity and we still+      -- need ltile not to break rooms (unless that's a good idea,+      -- but surely it's not for starship hull walls, vaults, fire pits, etc.,+      -- so perhaps all but impenetrable walls is game).+      let passes p@Point{..} array =+            px >= 0 && px <= cxsize - 1+            && py >= 0 && py <= cysize - 1+            && Tile.isWalkable cotile (array PointArray.! p)+          -- If no point blocks on both ends, then I can eventually go+          -- from bottom to top of the map and from left to right+          -- unless there are disconnected areas inside rooms).+          blocksHorizontal (Point x y) array =+            not (passes (Point (x + 1) y) array+                 || passes (Point (x - 1) y) array)+          blocksVertical (Point x y) array =+            not (passes (Point x (y + 1)) array+                 || passes (Point x (y - 1)) array)+          xeven Point{..} = px `mod` 2 == 0+          yeven Point{..} = py `mod` 2 == 0+          connect included blocks walkableTile array =+            let g n c = if included n+                           && not (Tile.isWalkable cotile c)+                           && n `EM.notMember` ltile+                           && blocks n array+                        then walkableTile+                        else c+            in PointArray.imapA g array+      walkable2 <- cdefTileWalkable+      let converted2 = connect xeven blocksHorizontal walkable2 converted1+      walkable3 <- cdefTileWalkable+      let converted3 = connect yeven blocksVertical walkable3 converted2+      walkable4 <- cdefTileWalkable+      let converted4 =+            connect (not . xeven) blocksHorizontal walkable4 converted3+      walkable5 <- cdefTileWalkable+      let converted5 =+            connect (not . yeven) blocksVertical walkable5 converted4+      return converted5  placeStairs :: Kind.Ops TileKind -> TileMap -> CaveKind -> [Point]             -> Rnd Point placeStairs cotile cmap CaveKind{..} ps = do   let dist cmin l _ = all (\pos -> chessDist l pos > cmin) ps   findPosTry 1000 cmap-    (\p t -> Tile.hasFeature cotile F.CanActor t+    (\p t -> Tile.isWalkable cotile t+             && not (Tile.hasFeature cotile F.NoActor t)              && dist 0 p t)  -- can't overwrite stairs with other stairs     [ dist $ cminStairDist     , dist $ cminStairDist `div` 2     , dist $ cminStairDist `div` 4+    , const $ Tile.hasFeature cotile F.OftenActor     , dist $ cminStairDist `div` 8     ] --- | Create a level from a cave, from a cave kind.-buildLevel :: Kind.COps -> Cave -> Int -> Int -> Int -> Int -> Maybe Bool+-- | Create a level from a cave.+buildLevel :: Kind.COps -> Cave+           -> AbsDepth -> LevelId -> LevelId -> LevelId -> AbsDepth+           -> Int -> Maybe Bool            -> Rnd Level buildLevel cops@Kind.COps{ cotile=cotile@Kind.Ops{opick, okind}                          , cocave=Kind.Ops{okind=cokind} }-           Cave{..} ldepth minD maxD nstairUp escapeFeature = do+           Cave{..} ldepth ln minD maxD totalDepth nstairUp escapeFeature = do   let kc@CaveKind{..} = cokind dkind       fitArea pos = inside pos . fromArea . qarea       findLegend pos = maybe clegendLitTile qlegend@@ -62,12 +114,22 @@       hasEscape p t = Tile.kindHasFeature (F.Cause $ Effect.Escape p) t       ascendable  = Tile.kindHasFeature $ F.Cause (Effect.Ascend 1)       descendable = Tile.kindHasFeature $ F.Cause (Effect.Ascend (-1))-      dcond kt = not (Tile.kindHasFeature F.Clear kt)-                 || (if dnight then id else not)-                      (Tile.kindHasFeature F.Dark kt)+      nightCond kt = (not (Tile.kindHasFeature F.Clear kt)+                      || (if dnight then id else not)+                            (Tile.kindHasFeature F.Dark kt))+      dcond kt = (cpassable+                  || not (Tile.kindHasFeature F.Walkable kt))+                 && nightCond kt       pickDefTile = fmap (fromMaybe $ assert `failure` cdefTile)                     $ opick cdefTile dcond-  cmap <- convertTileMaps pickDefTile cxsize cysize dmap+      wcond kt = Tile.kindHasFeature F.Walkable kt+                 && nightCond kt+      mpickWalkable =+        if cpassable+        then Just $ fmap (fromMaybe $ assert `failure` cdefTile)+                  $ opick cdefTile wcond+        else Nothing+  cmap <- convertTileMaps cotile pickDefTile mpickWalkable cxsize cysize dmap   -- We keep two-way stairs separately, in the last component.   let makeStairs :: Bool -> Bool -> Bool                  -> ( [(Point, Kind.Id TileKind)]@@ -98,17 +160,17 @@                      (True, True)  -> (up, down, st : upDown)                      (False, False) -> assert `failure` st   (stairsUp1, stairsDown1, stairsUpDown1) <--    makeStairs False (ldepth == maxD) (ldepth == minD) ([], [], [])+    makeStairs False (ln == maxD) (ln == minD) ([], [], [])   assert (null stairsUp1) skip   let nstairUpLeft = nstairUp - length stairsUpDown1   (stairsUp2, stairsDown2, stairsUpDown2) <--    foldM (\sts _ -> makeStairs True (ldepth == maxD) (ldepth == minD) sts)+    foldM (\sts _ -> makeStairs True (ln == maxD) (ln == minD) sts)           (stairsUp1, stairsDown1, stairsUpDown1)           [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 (ldepth == minD)+    then (makeStairs False True (ln == minD)              (stairsUp2, stairsDown2, stairsUpDown2))     else return (stairsUp2, stairsDown2, stairsUpDown2)   let stairsUpAndUpDown = stairsUp ++ stairsUpDown@@ -133,82 +195,86 @@       -- We reverse the order in down stairs, to minimize long stair chains.       lstair = ( map fst $ stairsUp ++ stairsUpDown                , map fst $ stairsUpDown ++ stairsDown )-  -- traceShow (ldepth, nstairUp, (stairsUp, stairsDown, stairsUpDown)) skip-  litemNum <- castDice citemNum-  let itemFreq = toFreq cname citemFreq-  assert (not $ nullFreq itemFreq) skip-  lsecret <- random+  -- traceShow (ln, nstairUp, (stairsUp, stairsDown, stairsUpDown)) skip+  litemNum <- castDice ldepth totalDepth citemNum+  lsecret <- randomR (1, maxBound)  -- 0 means unknown   return $! levelFromCaveKind cops kc ldepth ltile lstair-                              litemNum itemFreq lsecret (isJust escapeFeature)+                              cactorFreq litemNum citemFreq+                              lsecret (isJust escapeFeature) +-- | Build rudimentary level from a cave kind. levelFromCaveKind :: Kind.COps-                  -> CaveKind -> Int -> TileMap -> ([Point], [Point])-                  -> Int -> Frequency Text -> Int -> Bool+                  -> CaveKind -> AbsDepth -> TileMap -> ([Point], [Point])+                  -> Freqs -> Int -> Freqs -> Int -> Bool                   -> Level levelFromCaveKind Kind.COps{cotile}                   CaveKind{..}-                  ldepth ltile lstair litemNum litemFreq lsecret lescape =-  Level-    { ldepth-    , lprio = EM.empty-    , lfloor = EM.empty-    , ltile-    , lxsize = cxsize-    , lysize = cysize-    , lsmell = EM.empty-    , ldesc = cname-    , lstair-    , lseen = 0-    , lclear = let f n t | Tile.isExplorable cotile t = n + 1-                         | otherwise = n-               in PointArray.foldlA f 0 ltile-    , ltime = timeTurn-    , litemNum-    , litemFreq-    , lsecret-    , lhidden = chidden-    , lescape-    }+                  ldepth ltile lstair lactorFreq litemNum litemFreq+                  lsecret lescape =+  let lvl = Level+        { ldepth+        , lprio = EM.empty+        , lfloor = EM.empty+        , ltile+        , lxsize = cxsize+        , lysize = cysize+        , lsmell = EM.empty+        , ldesc = cname+        , lstair+        , lseen = 0+        , lclear = 0  -- calculated below+        , ltime = timeZero+        , lactorFreq+        , litemNum+        , litemFreq+        , lsecret+        , lhidden = chidden+        , lescape+        }+      f n t | Tile.isExplorable cotile t = n + 1+            | otherwise = n+      lclear = PointArray.foldlA f 0 ltile+  in lvl {lclear} -findGenerator :: Kind.COps -> Caves-              -> LevelId -> LevelId -> LevelId -> Int -> Int+findGenerator :: Kind.COps -> LevelId -> LevelId -> LevelId -> AbsDepth -> Int+              -> (Text, Maybe Bool)               -> Rnd Level-findGenerator cops caves ldepth minD maxD totalDepth nstairUp = do+findGenerator cops ln minD maxD totalDepth nstairUp+              (genName, escapeFeature) = do   let Kind.COps{cocave=Kind.Ops{opick}} = cops-      (genName, escapeFeature) =-        fromMaybe ("dng", Nothing) $ EM.lookup ldepth caves   ci <- fmap (fromMaybe $ assert `failure` genName)         $ opick genName (const True)-  cave <- buildCave cops (fromEnum ldepth) totalDepth ci-  buildLevel cops cave-             (fromEnum ldepth) (fromEnum minD) (fromEnum maxD) nstairUp-             escapeFeature+  -- 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+  buildLevel cops cave ldepth ln minD maxD totalDepth nstairUp escapeFeature  -- | Freshly generated and not yet populated dungeon. data FreshDungeon = FreshDungeon-  { freshDungeon :: !Dungeon  -- ^ maps for all levels-  , freshDepth   :: !Int      -- ^ dungeon depth (can be different than size)+  { freshDungeon    :: !Dungeon   -- ^ maps for all levels+  , freshTotalDepth :: !AbsDepth  -- ^ absolute dungeon depth   }  -- | Generate the dungeon for a new game. dungeonGen :: Kind.COps -> Caves -> Rnd FreshDungeon dungeonGen cops caves = do   let (minD, maxD) =-        case (EM.minViewWithKey caves, EM.maxViewWithKey caves) of+        case (IM.minViewWithKey caves, IM.maxViewWithKey caves) of           (Just ((s, _), _), Just ((e, _), _)) -> (s, e)           _ -> assert `failure` "no caves" `twith` caves-      totalDepth = if minD == maxD-                   then 10-                   else fromEnum maxD - fromEnum minD + 1-  let gen :: (Int, [(LevelId, Level)]) -> LevelId+      (minId, maxId) = (toEnum minD, toEnum maxD)+      freshTotalDepth = assert (signum minD == signum maxD)+                        $ AbsDepth+                        $ max 10 $ max (abs minD) (abs maxD)+  let gen :: (Int, [(LevelId, Level)]) -> (Int, (Text, Maybe Bool))           -> Rnd (Int, [(LevelId, Level)])-      gen (nstairUp, l) ldepth = do-        lvl <- findGenerator cops caves ldepth minD maxD totalDepth nstairUp+      gen (nstairUp, l) (n, caveTB) = do+        let ln = toEnum n+        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, (ldepth, lvl) : l)-  (nstairUpLast, levels) <- foldM gen (0, []) $ reverse [minD..maxD]+        return $ (nstairDown, (ln, lvl) : l)+  (nstairUpLast, levels) <- foldM gen (0, []) $ reverse $ IM.assocs caves   assert (nstairUpLast == 0) skip   let freshDungeon = EM.fromList levels-      freshDepth = totalDepth   return $! FreshDungeon{..}
Game/LambdaHack/Server/DungeonGen/AreaRnd.hs view
@@ -35,17 +35,13 @@ mkRoom (xm, ym) (xM, yM) area = do   let (x0, y0, x1, y1) = fromArea area   assert (xm <= x1 - x0 + 1 && ym <= y1 - y0 + 1) skip-  let a0 = (x0, y0, x1 - xm + 1, y1 - ym + 1)-      area0 = fromMaybe (assert `failure` a0) $ toArea a0-  Point rx0 ry0 <- xyInArea area0-  let sX = rx0 + xm - 1-      sY = ry0 + ym - 1-      eX = min x1 (rx0 + xM - 1)-      eY = min y1 (ry0 + yM - 1)-      a1 = (sX, sY, eX, eY)+  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+  let a1 = (x0, y0, max x0 (x1 - xW + 1), max y0 (y1 - yW + 1))       area1 = fromMaybe (assert `failure` a1) $ toArea a1-  Point rx1 ry1 <- xyInArea area1-  let a3 = (rx0, ry0, rx1, ry1)+  Point rx1 ry1 <- xyInArea area1  -- roll top-left corner+  let a3 = (rx1, ry1, rx1 + xW - 1, ry1 + yW - 1)       area3 = fromMaybe (assert `failure` a3) $ toArea a3   return $! area3 @@ -64,7 +60,7 @@ connectGrid :: (X, Y) -> Rnd [(Point, Point)] connectGrid (nx, ny) = do   let unconnected = S.fromList [ Point x y-                                | x <- [0..nx-1], y <- [0..ny-1] ]+                               | x <- [0..nx-1], y <- [0..ny-1] ]   -- Candidates are neighbours that are still unconnected. We start with   -- a random choice.   rx <- randomR (0, nx-1)@@ -95,7 +91,7 @@ -- | Sort the sequence of two points, in the derived lexicographic order. sortPoint :: (Point, Point) -> (Point, Point) sortPoint (a, b) | a <= b    = (a, b)-                   | otherwise = (b, a)+                 | otherwise = (b, a)  -- | Pick a single random connection between adjacent areas within a grid. randomConnection :: (X, Y) -> Rnd (Point, Point)
Game/LambdaHack/Server/DungeonGen/Cave.hs view
@@ -7,15 +7,17 @@ import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM+import Data.Key (mapWithKeyM) import Data.List import qualified Data.Map.Strict as M import Data.Maybe-import qualified Data.Traversable as Traversable  import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.CaveKind import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.TileKind@@ -57,16 +59,16 @@ -- TODO: fix identifier naming and split, after the code grows some more -- | Cave generation by an algorithm inspired by the original Rogue, buildCave :: Kind.COps         -- ^ content definitions-          -> Int               -- ^ depth of the level to generate-          -> Int               -- ^ maximum depth of the dungeon+          -> AbsDepth          -- ^ depth of the level to generate+          -> AbsDepth          -- ^ absolute depth           -> Kind.Id CaveKind  -- ^ cave kind to use for generation           -> Rnd Cave buildCave cops@Kind.COps{ cotile=cotile@Kind.Ops{opick}                         , cocave=Kind.Ops{okind}                         , coplace=Kind.Ops{okind=pokind} }-          ln depth dkind = do+          ldepth totalDepth dkind = do   let kc@CaveKind{..} = okind dkind-  lgrid@(gx, gy) <- castDiceXY cgrid+  lgrid@(gx, gy) <- castDiceXY ldepth totalDepth cgrid   -- Make sure that in caves not filled with rock, there is a passage   -- across the cave, even if a single room blocks most of the cave.   -- Also, ensure fancy outer fences are not obstructed by room walls.@@ -89,8 +91,8 @@        voidPl <- replicateM voidNum $ xyInArea gridArea  -- repetitions are OK        return (addedC, voidPl)     else return ([], [])-  minPlaceSize <- castDiceXY cminPlaceSize-  maxPlaceSize <- castDiceXY cmaxPlaceSize+  minPlaceSize <- castDiceXY ldepth totalDepth cminPlaceSize+  maxPlaceSize <- castDiceXY ldepth totalDepth cmaxPlaceSize   places0 <- mapM (\ (i, r) -> do                      -- Reserved for corridors and the global fence.                      let innerArea = fromMaybe (assert `failure` (i, r))@@ -101,7 +103,7 @@                                                     maxPlaceSize innerArea                      return (i, r')) gs   fence <- buildFenceRnd cops couterFenceTile subFullArea-  dnight <- chanceDeep ln depth cnightChance+  dnight <- chanceDice ldepth totalDepth cnightChance   darkCorTile <- fmap (fromMaybe $ assert `failure` cdarkCorTile)                  $ opick cdarkCorTile (const True)   litCorTile <- fmap (fromMaybe $ assert `failure` clitCorTile)@@ -110,7 +112,7 @@       addPl (m, pls, qls) (i, Left r) = return (m, pls, (i, Left r) : qls)       addPl (m, pls, qls) (i, Right r) = do         (tmap, place) <--          buildPlace cops kc dnight darkCorTile litCorTile ln depth r+          buildPlace cops kc dnight darkCorTile litCorTile ldepth totalDepth r         return (EM.union tmap m, place : pls, (i, Right (r, place)) : qls)   (lplaces, dplaces, qplaces0) <- foldM addPl (fence, [], []) places0   connects <- connectGrid lgrid@@ -133,30 +135,40 @@                     rr1 = shrinkForFence $ qplaces M.! p1                 connectPlaces rr0 rr1) allConnects   let lcorridors = EM.unions (map (digCorridors pickedCorTile) cs)-      lm = EM.unionWith (mergeCorridor cotile) lcorridors lplaces+      lm = EM.union lplaces lcorridors   -- Convert wall openings into doors, possibly.-  let f t =-        if not $ Tile.isSuspect cotile t-          -- May also turn a cache into a floor (and/or a pillar?); tough luck.-          -- TODO: the floor may be lit while it should be dark.-        then return t  -- no opening to start with+  let f pos (t, cor) = do+        -- Openings have a certain chance to be doors+        -- and doors have a certain chance to be open.+        rd <- chance cdoorChance+        if not rd then  -- opening kept+          if Tile.isLit cotile cor then return cor+          else do+            -- If any adjacent room tile is lit, make the opening lit.+            let roomTileLit p =+                  case EM.lookup p lplaces of+                    Nothing -> False+                    Just tile -> Tile.isLit cotile tile+                vic = vicinity cxsize cysize pos+            if any roomTileLit vic+              then return litCorTile+              else return cor         else do-          -- Openings have a certain chance to be doors-          -- and doors have a certain chance to be open.-          rd <- chance cdoorChance-          if not rd then-            let cor = if Tile.isLit cotile t then litCorTile else darkCorTile-            in return $! cor  -- opening kept+          ro <- chance copenChance+          doorClosedId <- Tile.revealAs cotile t+          if not ro then return $! doorClosedId           else do-            ro <- chance copenChance-            doorClosedId <- Tile.revealAs cotile t-            if not ro then-              return $! doorClosedId-            else do-              doorOpenId <- Tile.openTo cotile doorClosedId-              return $! doorOpenId-  dmap <- Traversable.mapM f lm-  let cave = Cave+            doorOpenId <- Tile.openTo cotile doorClosedId+            return $! doorOpenId+      mergeCor _ pl cor =+        let hidden = Tile.hideAs cotile pl+        in if hidden == pl then Nothing else Just (hidden, cor)+      intersectionCombine combine =+        EM.mergeWithKey combine (const EM.empty) (const EM.empty)+      interCor = intersectionCombine mergeCor lplaces lcorridors+  doorMap <- mapWithKeyM f interCor+  let dmap = EM.union doorMap lm+      cave = Cave         { dkind         , dmap         , dplaces@@ -171,7 +183,3 @@   cor  = fromTo p1 p2   corPos = EM.fromList $ zip cor (repeat tile) digCorridors _ _ = EM.empty--mergeCorridor :: Kind.Ops TileKind -> Kind.Id TileKind -> Kind.Id TileKind-              -> Kind.Id TileKind-mergeCorridor cotile _ = Tile.hideAs cotile
Game/LambdaHack/Server/DungeonGen/Place.hs view
@@ -12,8 +12,11 @@ import Data.Text (Text) import qualified Data.Text as T +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.Msg import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Content.CaveKind@@ -58,11 +61,13 @@           dycorner = length ptopLeft           wholeOverlapped d dcorner = d > 1 && dcorner > 1 &&                                       (d - 1) `mod` (2 * (dcorner - 1)) == 0+          largeEnough = dx >= 2 * dxcorner - 1 && dy >= 2 * dycorner - 1       in case pcover of         CAlternate -> wholeOverlapped dx dxcorner &&                       wholeOverlapped dy dycorner-        _          -> dx >= 2 * dxcorner - 1 &&-                      dy >= 2 * dycorner - 1+        CStretch   -> largeEnough+        CReflect   -> largeEnough+        CVerbatim  -> dx >= dxcorner && dy >= dycorner  -- | Calculate interior room area according to fence type, based on the -- total area for the room and it's fence. This is used for checking@@ -82,29 +87,47 @@            -> Bool              -- ^ whether the cave is dark            -> Kind.Id TileKind  -- ^ dark fence tile, if fence hollow            -> Kind.Id TileKind  -- ^ lit fence tile, if fence hollow-           -> Int               -- ^ current level depth-           -> Int               -- ^ maximum depth+           -> AbsDepth          -- ^ current level depth+           -> AbsDepth          -- ^ absolute depth            -> Area              -- ^ whole area of the place, fence included            -> Rnd (TileMapEM, Place) buildPlace Kind.COps{ cotile=cotile@Kind.Ops{opick=opick}-                    , coplace=Kind.Ops{okind=pokind, opick=popick} }-           CaveKind{..} dnight darkCorTile litCorTile ln depth r = do+                    , coplace=Kind.Ops{ofoldrGroup} }+           CaveKind{..} dnight darkCorTile litCorTile+           ldepth@(AbsDepth ld) totalDepth@(AbsDepth depth) r = do   qsolidFence <- fmap (fromMaybe $ assert `failure` cfillerTile)                  $ opick cfillerTile (const True)-  dark <- chanceDeep ln depth cdarkChance-  let cave = "rogue"-  qkind <- fmap (fromMaybe $ assert `failure` (cave, r))-           $ popick cave (placeCheck r)+  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+        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)+  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+  ((qkind, kr), _) <- frequency freq   let qhollowFence = if dark then darkCorTile else litCorTile-      kr = pokind qkind       qlegend = if dark then clegendDarkTile else clegendLitTile       qseen = False       qarea = fromMaybe (assert `failure` (kr, r)) $ interiorArea (pfence kr) r       place = Place {..}+  override <- ooverride cotile (poverride kr)   legend <- olegend cotile qlegend   legendLit <- olegend cotile clegendLitTile-  let xlegend = EM.insert 'X' qhollowFence legend-      xlegendLit = EM.insert 'X' qhollowFence legendLit+  let xlegend = EM.union override legend+      xlegendLit = EM.union override legendLit       cmap = tilePlace qarea kr       fence = case pfence kr of         FWall -> buildFence qsolidFence qarea@@ -112,11 +135,13 @@         FNone -> EM.empty       (x0, y0, x1, y1) = fromArea qarea       isEdge (Point x y) = x `elem` [x0, x1] || y `elem` [y0, y1]-      digNight xy c | isEdge xy = xlegendLit EM.! c-                    | otherwise = xlegend EM.! c+      digDay xy c | isEdge xy = xlegendLit EM.! c+                  | otherwise = xlegend EM.! c       interior = case pfence kr of-        FNone | not dnight -> EM.mapWithKey digNight cmap-        _ -> EM.map (xlegend EM.!) cmap+        FNone | not dnight -> EM.mapWithKey digDay cmap+        _ -> let lookupLegend x = fromMaybe (assert `failure` (qlegend, x))+                                  $ EM.lookup x xlegend+             in EM.map lookupLegend cmap       tmap = EM.union interior fence   return (tmap, place) @@ -136,6 +161,17 @@       legend = ES.foldr getLegend (return EM.empty) symbols   in legend +ooverride :: Kind.Ops TileKind -> [(Char, Text)]+          -> Rnd (EM.EnumMap Char (Kind.Id TileKind))+ooverride 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+        return $! EM.insert s tk m+      legend = foldr getLegend (return EM.empty) poverride+  in legend+ -- | Construct a fence around an area, with the given tile kind. buildFence :: Kind.Id TileKind -> Area -> TileMapEM buildFence fenceId area =@@ -180,8 +216,14 @@         zipWith (\x y -> Point x y) [x2..] (repeat y2)       fillInterior :: (forall a. Int -> [a] -> [a]) -> [(Point, Char)]       fillInterior f =-        let tileInterior (y, row) = zip (fromX (x0, y)) $ f dx row-            reflected = zip [y0..] $ f dy $ map T.unpack ptopLeft+        let tileInterior (y, row) =+              let fx = f dx row+                  xStart = x0 + ((xwidth - length fx) `div` 2)+              in filter ((/= 'X') . snd) $ zip (fromX (xStart, y)) fx+            reflected =+              let fy = f dy $ map T.unpack ptopLeft+                  yStart = y0 + ((ywidth - length fy) `div` 2)+              in zip [yStart..] fy         in concatMap tileInterior reflected       tileReflect :: Int -> [a] -> [a]       tileReflect d pat =@@ -203,6 +245,7 @@           let reflect :: Int -> [a] -> [a]               reflect d pat = tileReflect d (cycle pat)           in fillInterior reflect+        CVerbatim -> fillInterior $ curry snd   in EM.fromList interior  instance Binary Place where
− Game/LambdaHack/Server/EffectSem.hs 
@@ -1,538 +0,0 @@--- | Effect semantics.--- TODO: document-module Game.LambdaHack.Server.EffectSem-  ( -- + Semantics of effects-    itemEffect, effectSem-    -- * Assorted operations-  , registerItem, createItems, addHero, spawnMonsters-  , electLeader, deduceKilled-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.Char as Char-import qualified Data.EnumMap.Strict as EM-import qualified Data.HashMap.Strict as HM-import Data.Key (mapWithKeyM_)-import Data.List-import Data.Maybe-import Data.Ratio ((%))-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.AtomicCmd-import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ActorKind-import Game.LambdaHack.Content.FactionKind-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Server.Action-import Game.LambdaHack.Server.State-import Game.LambdaHack.Utils.Frequency---- + Semantics of effects---- TODO: when h2h items have ItemId, replace Item with ItemId--- | The source actor affects the target actor, with a given item.--- If the event is seen, the item may get identified. This function--- is mutually recursive with @effect@ and so it's a part of @Effect@--- semantics.-itemEffect :: (MonadAtomic m, MonadServer m)-           => ActorId -> ActorId -> Maybe ItemId -> Item-           -> m ()-itemEffect source target miid item = do-  discoS <- getsServer sdisco-  let ik = fromJust $ jkind discoS item-      ef = jeffect item-  b <- effectSem ef source target-  -- The effect is interesting so the item gets identified, if seen-  -- (the item is in source actor's inventory, so his position is given,-  -- note that the actor may be moved by the effect; the item is destroyed,-  -- if ever, after the discovery happens).-  postb <- getsState $ getActorBody source-  let atomic iid = execCmdAtomic $ DiscoverA (blid postb) (bpos postb) iid ik-  when b $ maybe skip atomic miid---- | The source actor affects the target actor, with a given effect and power.--- Both actors are on the current level and can be the same actor.--- The boolean result indicates if the effect was spectacular enough--- for the actors to identify it (and the item that caused it, if any).-effectSem :: (MonadAtomic m, MonadServer m)-          => Effect.Effect Int -> ActorId -> ActorId-          -> m Bool-effectSem effect source target = case effect of-  Effect.NoEffect -> effectNoEffect target-  Effect.Heal p -> effectHeal p target-  Effect.Hurt nDm p -> effectWound nDm p source target-  Effect.Mindprobe _ -> effectMindprobe target-  Effect.Dominate | source /= target -> effectDominate source target-  Effect.Dominate -> effectSem (Effect.Mindprobe undefined) source target-  Effect.CallFriend p -> effectCallFriend p source target-  Effect.Summon p -> effectSummon p target-  Effect.CreateItem p -> effectCreateItem p target-  Effect.ApplyPerfume -> effectApplyPerfume source target-  Effect.Regeneration p -> effectSem (Effect.Heal p) source target-  Effect.Searching p -> effectSearching p source-  Effect.Ascend p -> effectAscend p target-  Effect.Escape{} -> effectEscape target---- + Individual semantic functions for effects---- ** NoEffect--effectNoEffect :: MonadAtomic m => ActorId -> m Bool-effectNoEffect target = do-  execSfxAtomic $ EffectD target Effect.NoEffect-  return False---- ** Heal--effectHeal :: MonadAtomic m-           => Int -> ActorId -> m Bool-effectHeal power target = do-  Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops-  tm <- getsState $ getActorBody target-  let bhpMax = maxDice (ahp $ okind $ bkind tm)-  if power > 0 && bhp tm >= bhpMax-    then do-      execSfxAtomic $ EffectD target Effect.NoEffect-      return False-    else do-      let deltaHP = min power (bhpMax - bhp tm)-      execCmdAtomic $ HealActorA target deltaHP-      execSfxAtomic $ EffectD target $ Effect.Heal deltaHP-      return True---- ** Wound--effectWound :: (MonadAtomic m, MonadServer m)-            => RollDice -> Int -> ActorId -> ActorId-            -> m Bool-effectWound nDm power source target = do-  n <- rndToAction $ castDice nDm-  let deltaHP = - (n + power)-  if deltaHP >= 0-    then do-      execSfxAtomic $ EffectD target Effect.NoEffect-      return False-    else do-      -- Damage the target.-      execCmdAtomic $ HealActorA target deltaHP-      execSfxAtomic $ EffectD target $-        if source == target-        then Effect.Heal deltaHP-        else Effect.Hurt nDm deltaHP{-hack-}-      return True---- ** Mindprobe--effectMindprobe :: MonadAtomic m-                => ActorId -> m Bool-effectMindprobe target = do-  tb <- getsState (getActorBody target)-  let lid = blid tb-  fact <- getsState $ (EM.! bfid tb) . sfactionD-  lb <- getsState $ actorNotProjList (isAtWar fact) lid-  let nEnemy = length lb-  if nEnemy == 0 || bproj tb then do-    execSfxAtomic $ EffectD target Effect.NoEffect-    return False-  else do-    execSfxAtomic $ EffectD target $ Effect.Mindprobe nEnemy-    return True---- ** Dominate--effectDominate :: (MonadAtomic m, MonadServer m)-               => ActorId -> ActorId -> m Bool-effectDominate source target = do-  sb <- getsState (getActorBody source)-  tb <- getsState (getActorBody target)-  if bfid tb == bfid sb || bproj tb then do  -- TODO: drop the projectile?-    execSfxAtomic $ EffectD target Effect.NoEffect-    return False-  else do-    -- Announce domination before the actor changes sides.-    execSfxAtomic $ EffectD target Effect.Dominate-    -- TODO: Perhaps insert a turn of delay here to allow countermeasures.-    electLeader (bfid tb) (blid tb) target-    deduceKilled tb-    ais <- getsState $ getActorItem target-    execCmdAtomic $ LoseActorA target tb ais-    let bNew = tb {bfid = bfid sb}-    execCmdAtomic $ CreateActorA target bNew ais-    leaderOld <- getsState $ gleader . (EM.! bfid sb) . sfactionD-    -- Halve the speed as a side-effect of domination.-    let speed = bspeed bNew-        delta = speedScale (1%2) speed-    when (delta > speedZero) $-      execCmdAtomic $ HasteActorA target (speedNegate delta)-    execCmdAtomic $ LeadFactionA (bfid sb) leaderOld (Just target)-    return True--electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m ()-electLeader fid lid aidDead = do-  mleader <- getsState $ gleader . (EM.! fid) . sfactionD-  when (isNothing mleader || mleader == Just aidDead) $ do-    actorD <- getsState sactorD-    let ours (_, b) = bfid b == fid && not (bproj b)-        party = filter ours $ EM.assocs actorD-    onLevel <- getsState $ actorNotProjAssocs (== fid) lid-    let mleaderNew = listToMaybe $ filter (/= aidDead)-                     $ map fst $ onLevel ++ party-    unless (mleader == mleaderNew) $-      execCmdAtomic $ LeadFactionA fid mleader mleaderNew--deduceKilled :: (MonadAtomic m, MonadServer m) => Actor -> m ()-deduceKilled body = do-  cops@Kind.COps{corule} <- getsState scops-  let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule-      fid = bfid body-  spawn <- getsState $ isSpawnFaction fid-  fact <- getsState $ (EM.! fid) . sfactionD-  let horror = isHorrorFact cops fact-  mleader <- getsState $ gleader . (EM.! fid) . sfactionD-  when (not spawn && not horror-        && (isNothing mleader || firstDeathEnds)) $-    deduceQuits body $ Status Killed (fromEnum $ blid body) ""---- ** SummonFriend--effectCallFriend :: (MonadAtomic m, MonadServer m)-                   => Int -> ActorId -> ActorId-                   -> m Bool-effectCallFriend power source target = assert (power > 0) $ do-  -- Obvious effect, nothing announced.-  Kind.COps{cotile} <- getsState scops-  sm <- getsState (getActorBody source)-  tm <- getsState (getActorBody target)-  ps <- getsState $ nearbyFreePoints cotile (const True) (bpos tm) (blid tm)-  summonFriends (bfid sm) (take power ps) (blid tm)-  return True--summonFriends :: (MonadAtomic m, MonadServer m)-              => FactionId -> [Point] -> LevelId-              -> m ()-summonFriends bfid ps lid = do-  Kind.COps{ coactor=coactor@Kind.Ops{opick}-           , cofaction=Kind.Ops{okind} } <- getsState scops-  time <- getsState $ getLocalTime lid-  factionD <- getsState sfactionD-  let fact = okind $ gkind $ factionD EM.! bfid-  forM_ ps $ \p -> do-    let summonName = fname fact-    mk <- rndToAction $ fmap (fromMaybe $ assert `failure` summonName)-                        $ opick summonName (const True)-    if mk == heroKindId coactor-      then addHero bfid p lid [] Nothing time-      else addMonster mk bfid p lid time-  -- No leader election needed, bebause an alive actor of the same faction-  -- causes the effect, so there is already a leader.--addActor :: (MonadAtomic m, MonadServer m)-         => Kind.Id ActorKind -> FactionId -> Point -> LevelId -> Int-         -> Char -> Text -> Color.Color -> Time-         -> m ActorId-addActor mk bfid pos lid hp bsymbol bname bcolor time = do-  Kind.COps{coactor=coactor@Kind.Ops{okind}} <- getsState scops-  Faction{gplayer} <- getsState $ (EM.! bfid) . sfactionD-  DebugModeSer{sdifficultySer} <- getsServer sdebugSer-  nU <- nUI-  -- If no UI factions, the difficulty applies to heroes (for testing).-  let diffHP | playerUI gplayer || nU == 0 && mk == heroKindId coactor =-        (ceiling :: Double -> Int) $ fromIntegral hp * 1.5 ^^ sdifficultySer-             | otherwise = hp-      kind = okind mk-      speed = aspeed kind-      m = actorTemplate mk bsymbol bname bcolor speed diffHP-                        Nothing pos lid time bfid False-  acounter <- getsServer sacounter-  modifyServer $ \ser -> ser {sacounter = succ acounter}-  execCmdAtomic $ CreateActorA acounter m []-  return $! acounter---- | Create a new hero on the current level, close to the given position.-addHero :: (MonadAtomic m, MonadServer m)-        => FactionId -> Point -> LevelId -> [(Int, Text)] -> Maybe Int -> Time-        -> m ActorId-addHero bfid ppos lid heroNames mNumber time = do-  Kind.COps{coactor=coactor@Kind.Ops{okind}} <- getsState scops-  Faction{gcolor, gplayer} <- getsState $ (EM.! bfid) . sfactionD-  let kId = heroKindId coactor-  hp <- rndToAction $ castDice $ ahp $ okind kId-  mhs <- mapM (\n -> getsState $ \s -> tryFindHeroK s bfid n) [0..9]-  let freeHeroK = elemIndex Nothing mhs-      n = fromMaybe (fromMaybe 100 freeHeroK) mNumber-      symbol = if n < 1 || n > 9 then '@' else Char.intToDigit n-      nameFromNumber 0 = "Captain"-      nameFromNumber k = "Hero" <+> tshow k-      name | gcolor == Color.BrWhite =-        fromMaybe (nameFromNumber n) $ lookup n heroNames-           | otherwise =-        playerName gplayer <+> nameFromNumber n-      startHP = hp - (min 10 $ hp `div` 10) * min 5 n-  addActor kId bfid ppos lid startHP symbol name gcolor time---- ** SpawnMonster--effectSummon :: (MonadAtomic m, MonadServer m)-             => Int -> ActorId -> m Bool-effectSummon power target = assert (power > 0) $ do-  -- Obvious effect, nothing announced.-  Kind.COps{cotile} <- getsState scops-  tm <- getsState (getActorBody target)-  ps <- getsState $ nearbyFreePoints cotile (const True) (bpos tm) (blid tm)-  time <- getsState $ getLocalTime (blid tm)-  mfid <- pickFaction "summon" (const True)-  case mfid of-    Nothing -> return False  -- no faction summons-    Just fid -> do-      spawnMonsters (take power ps) (blid tm) time fid-      return True---- | Spawn non-hero actors of any faction, friendly or not.--- To be used for initial dungeon population, spontaneous spawning--- of monsters and for the summon effect.-spawnMonsters :: (MonadAtomic m, MonadServer m)-              => [Point] -> LevelId -> Time -> FactionId-              -> m ()-spawnMonsters ps lid time fid = assert (not $ null ps) $ do-  Kind.COps{coactor=Kind.Ops{opick}, cofaction=Kind.Ops{okind}} <- getsState scops-  fact <- getsState $ (EM.! fid) . sfactionD-  let spawnName = fname $ okind $ gkind fact-  laid <- forM ps $ \ p -> do-    mk <- rndToAction $ fmap (fromMaybe $ assert `failure` spawnName)-                        $ opick spawnName (const True)-    addMonster mk fid p lid time-  mleader <- getsState $ gleader . (EM.! fid) . sfactionD  -- just changed-  when (isNothing mleader) $-    execCmdAtomic $ LeadFactionA fid Nothing (Just $ head laid)---- | Roll a faction based on faction kind frequency key.-pickFaction :: MonadServer m-            => Text-            -> ((FactionId, Faction) -> Bool)-            -> m (Maybe FactionId)-pickFaction freqChoice ffilter = do-  Kind.COps{cofaction=Kind.Ops{okind}} <- getsState scops-  factionD <- getsState sfactionD-  let f (fid, fact) = let kind = okind (gkind fact)-                          g n = (n, fid)-                      in fmap g $ lookup freqChoice $ ffreq kind-      flist = mapMaybe f $ filter ffilter $ EM.assocs factionD-      freq = toFreq ("pickFaction" <+> freqChoice) flist-  if nullFreq freq then return Nothing-  else fmap Just $ rndToAction $ frequency freq---- | Create a new monster on the level, at a given position--- and with a given actor kind and HP.-addMonster :: (MonadAtomic m, MonadServer m)-           => Kind.Id ActorKind -> FactionId -> Point -> LevelId -> Time-           -> m ActorId-addMonster mk bfid ppos lid time = do-  Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops-  let kind = okind mk-  hp <- rndToAction $ castDice $ ahp kind-  addActor mk bfid ppos lid hp (asymbol kind) (aname kind) (acolor kind) time---- ** CreateItem--effectCreateItem :: (MonadAtomic m, MonadServer m)-                 => Int -> ActorId -> m Bool-effectCreateItem power target = assert (power > 0) $ do-  -- Obvious effect, nothing announced.-  tm <- getsState $ getActorBody target-  void $ createItems power (bpos tm) (blid tm)-  return True--createItems :: (MonadAtomic m, MonadServer m)-            => Int -> Point -> LevelId -> m ()-createItems n pos lid = do-  Kind.COps{coitem} <- getsState scops-  flavour <- getsServer sflavour-  discoRev <- getsServer sdiscoRev-  Level{ldepth, litemFreq} <- getLevel lid-  depth <- getsState sdepth-  let container = CFloor lid pos-  replicateM_ n $ do-    (item, k, _) <- rndToAction-                    $ newItem coitem flavour discoRev litemFreq ldepth depth-    void $ registerItem item k container True--registerItem :: (MonadAtomic m, MonadServer m)-             => Item -> Int -> Container -> Bool -> m ItemId-registerItem item k container verbose = do-  itemRev <- getsServer sitemRev-  let cmd = if verbose then CreateItemA else SpotItemA-  case HM.lookup item itemRev of-    Just iid -> do-      -- TODO: try to avoid this case for createItems,-      -- to make items more interesting-      execCmdAtomic $ cmd iid item k container-      return iid-    Nothing -> do-      icounter <- getsServer sicounter-      modifyServer $ \ser ->-        ser { sicounter = succ icounter-            , sitemRev = HM.insert item icounter (sitemRev ser) }-      execCmdAtomic $ cmd icounter item k container-      return $! icounter---- ** ApplyPerfume--effectApplyPerfume :: MonadAtomic m-                   => ActorId -> ActorId -> m Bool-effectApplyPerfume source target =-  if source == target-  then do-    execSfxAtomic $ EffectD target Effect.NoEffect-    return False-  else do-    tm <- getsState $ getActorBody target-    Level{lsmell} <- getLevel $ blid tm-    let f p fromSm =-          execCmdAtomic $ AlterSmellA (blid tm) p (Just fromSm) Nothing-    mapWithKeyM_ f lsmell-    execSfxAtomic $ EffectD target Effect.ApplyPerfume-    return True---- ** Regeneration---- ** Searching---- TODO or to remove.-effectSearching :: MonadAtomic m => Int -> ActorId -> m Bool-effectSearching power source = do-  execSfxAtomic $ EffectD source $ Effect.Searching power-  return True---- ** Ascend--effectAscend :: MonadAtomic m => Int -> ActorId -> m Bool-effectAscend power target = do-  mfail <- effLvlGoUp target power-  case mfail of-    Nothing -> do-      execSfxAtomic $ EffectD target $ Effect.Ascend power-      return True-    Just failMsg -> do-      b <- getsState $ getActorBody target-      execSfxAtomic $ MsgFidD (bfid b) failMsg-      return False--effLvlGoUp :: MonadAtomic m => ActorId -> Int -> m (Maybe Msg)-effLvlGoUp aid k = do-  b1 <- getsState $ getActorBody aid-  ais1 <- getsState $ getActorItem aid-  let lid1 = blid b1-      pos1 = bpos b1-  (lid2, pos2) <- getsState $ whereTo lid1 pos1 k . sdungeon-  if lid2 == lid1 && pos2 == pos1 then-    return $ Just "The effect fizzles: no more levels in this direction."-  else if bproj b1 then-    assert `failure` "projectiles can't exit levels" `twith` (aid, k, b1)-  else do-    let switch1 = switchLevels1 ((aid, b1), ais1)-        switch2 = do-          -- Move the actor to where the inhabitant was, if any.-          switchLevels2 lid2 pos2 ((aid, b1), ais1)-          -- Verify only one non-projectile actor on every tile.-          !_ <- getsState $ posToActors pos1 lid1  -- assertion is inside-          !_ <- getsState $ posToActors pos2 lid2  -- assertion is inside-          return Nothing-    -- The actor is added to the new level, but there can be other actors-    -- at his new position.-    inhabitants <- getsState $ posToActors pos2 lid2-    case inhabitants of-      [] -> do-        switch1-        switch2-      ((_, b2), _) : _ -> do-        -- Alert about the switch.-        let subjects = map (partActor . snd . fst) inhabitants-            subject = MU.WWandW subjects-            verb = "be pushed to another level"-            msg2 = makeSentence [MU.SubjectVerbSg subject verb]-        -- Only tell one player, even if many actors, because then-        -- they are projectiles, so not too important.-        execSfxAtomic $ MsgFidD (bfid b2) msg2-        -- Move the actor out of the way.-        switch1-        -- Move the inhabitant out of the way.-        mapM_ switchLevels1 inhabitants-        -- Move the inhabitant to where the actor was.-        mapM_ (switchLevels2 lid1 pos1) inhabitants-        switch2--switchLevels1 :: MonadAtomic m => ((ActorId, Actor), [(ItemId, Item)]) -> m ()-switchLevels1 ((aid, bOld), ais) = do-  let side = bfid bOld-  mleader <- getsState $ gleader . (EM.! side) . sfactionD-  -- Prevent leader pointing to a non-existing actor.-  when (not (bproj bOld) && isJust mleader) $-    -- Trouble, if the actors are of the same faction.-    execCmdAtomic $ LeadFactionA side mleader Nothing-  -- Remove the actor from the old level.-  -- Onlookers see somebody disappear suddenly.-  -- @DestroyActorA@ is too loud, so use @LoseActorA@ instead.-  execCmdAtomic $ LoseActorA aid bOld ais--switchLevels2 :: MonadAtomic m-              => LevelId -> Point -> ((ActorId, Actor), [(ItemId, Item)])-              -> m ()-switchLevels2 lidNew posNew ((aid, bOld), ais) = do-  let lidOld = blid bOld-      side = bfid bOld-  assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) skip-  -- Sync the actor time with the level time.-  timeOld <- getsState $ getLocalTime lidOld-  timeLastVisited <- getsState $ getLocalTime lidNew-  -- This time calculation may cause a double move of a foe of the same-  -- speed, but this is OK --- the foe didn't have a chance to move-  -- before, because the arena went inactive, so he moves now one more time.-  let delta = timeAdd (btime bOld) (timeNegate timeOld)-      bNew = bOld { blid = lidNew-                  , btime = timeAdd timeLastVisited delta-                  , bpos = posNew-                  , boldpos = posNew  -- new level, new direction-                  , boldlid = lidOld }  -- record old level-  mleader <- getsState $ gleader . (EM.! side) . sfactionD-  -- Materialize the actor at the new location.-  -- Onlookers see somebody appear suddenly. The actor himself-  -- sees new surroundings and has to reset his perception.-  execCmdAtomic $ CreateActorA aid bNew ais-  -- Changing levels is so important, that the leader changes.-  -- This also helps the actor clear the staircase and so avoid-  -- being pushed back to the level he came from by another actor.-  when (not (bproj bOld) && isNothing mleader) $-    -- Trouble, if the actors are of the same faction.-    execCmdAtomic $ LeadFactionA side Nothing (Just aid)---- ** Escape---- | The faction leaves the dungeon.-effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> m Bool-effectEscape aid = do-  -- Obvious effect, nothing announced.-  cops <- getsState scops-  b <- getsState $ getActorBody aid-  let fid = bfid b-  fact <- getsState $ (EM.! fid) . sfactionD-  if not (isHeroFact cops fact) || bproj b then-    return False-  else do-    deduceQuits b $ Status Escape (fromEnum $ blid b) ""-    return True
+ Game/LambdaHack/Server/EndServer.hs view
@@ -0,0 +1,95 @@+-- | The main loop of the server, processing human and computer player+-- moves turn by turn.+module Game.LambdaHack.Server.EndServer+  ( endOrLoop, dieSer, dropEqpItems+  ) where++import Control.Monad+import qualified Data.EnumMap.Strict as EM+import Data.Maybe++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.State+import Game.LambdaHack.Server.CommonServer+import Game.LambdaHack.Server.HandleEffectServer+import Game.LambdaHack.Server.ItemServer+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++-- | Continue or exit or restart the game.+endOrLoop :: (MonadAtomic m, MonadServer m)+          => m () -> m () -> m () -> m () -> m ()+endOrLoop loop restart gameExit gameSave = do+  factionD <- getsState sfactionD+  let inGame fact = case gquit fact of+        Nothing -> True+        Just Status{stOutcome=Camping} -> True+        _ -> False+      gameOver = not $ any inGame $ EM.elems factionD+  let getQuitter fact = case gquit fact of+        Just Status{stOutcome=Restart, stInfo} -> Just stInfo+        _ -> Nothing+      quitters = mapMaybe getQuitter $ EM.elems factionD+  let isCamper fact = case gquit fact of+        Just Status{stOutcome=Camping} -> True+        _ -> False+      campers = filter (isCamper . snd) $ EM.assocs factionD+  -- Wipe out the quit flag for the savegame files.+  mapM_ (\(fid, fact) ->+            execUpdAtomic+            $ UpdQuitFaction fid Nothing (gquit fact) Nothing) campers+  bkpSave <- getsServer sbkpSave+  when bkpSave $ do+    modifyServer $ \ser -> ser {sbkpSave = False}+    gameSave+  case (quitters, campers) of+    (sgameMode : _, _) -> do+      modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {sgameMode}}+      restart+    _ | gameOver -> restart+    ([], []) -> 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+  -- 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+    dropEqpItems aid b hit+    b2 <- getsState $ getActorBody aid+    execUpdAtomic $ UpdDestroyActor aid b2 []+  else do+    disco <- getsServer sdisco+    trunk <- getsState $ getItemBody $ btrunk b+    let ikind = disco EM.! jkindIx trunk+    execUpdAtomic $ UpdRecordKill aid ikind 1+    electLeader (bfid b) (blid b) aid+    equipAllItems aid b+    dropEqpItems aid b False+    b2 <- getsState $ getActorBody aid+    execUpdAtomic $ UpdDestroyActor aid b2 []+    deduceKilled b++equipAllItems :: (MonadAtomic m, MonadServer m)+              => ActorId -> Actor -> m ()+equipAllItems aid b = 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.+  when (isNothing $ gleader fact) $ moveStores aid CSha CEqp+  moveStores aid CInv CEqp++-- | Drop all actor's items. If the actor hits another actor and this+-- collision results in all item being dropped, all items are destroyed.+-- If the actor does not hit, but dies, only fragile items are destroyed+-- and only if the actor was a projectile (and so died by dropping+-- to the ground due to exceeded range or bumping off an obstacle).+dropEqpItems :: (MonadAtomic m, MonadServer m)+             => ActorId -> Actor -> Bool -> m ()+dropEqpItems aid b hit = mapActorCStore_ CEqp (dropEqpItem aid b hit) b
Game/LambdaHack/Server/Fov.hs view
@@ -1,121 +1,203 @@ -- | Field Of View scanning with a variety of algorithms.--- See <https://github.com/kosmikus/LambdaHack/wiki/Fov-and-los>+-- See <https://github.com/LambdaHack/LambdaHack/wiki/Fov-and-los> -- for discussion. module Game.LambdaHack.Server.Fov-  ( dungeonPerception, levelPerception, fullscan+  ( dungeonPerception, fidLidPerception+  , PersLit, litInDungeon   ) 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.Ord  import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Effect as Effect 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 Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ActorKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Server.Fov.Common import qualified Game.LambdaHack.Server.Fov.Digital as Digital import qualified Game.LambdaHack.Server.Fov.Permissive as Permissive import qualified Game.LambdaHack.Server.Fov.Shadow as Shadow+import Game.LambdaHack.Server.State +-- | Visually reachable position (light passes through them to the actor). newtype PerceptionReachable = PerceptionReachable     {preachable :: [Point]}   deriving Show --- | Calculate perception of the level.-levelPerception :: Kind.COps -> FovMode -> FactionId-                -> LevelId -> Level -> State+-- | All lit positions on a level.+newtype PerceptionLit = PerceptionLit+    {plit :: ES.EnumSet Point}+  deriving Show++type ActorEqpBody = [((ActorId, Actor), [ItemFull])]++type PersLit = EML.EnumMap LevelId ( PerceptionLit+                                   , EM.EnumMap FactionId ActorEqpBody )++-- | Calculate faction's perception of a level.+levelPerception :: Kind.COps -> PerceptionLit -> ActorEqpBody+                -> FovMode -> Level                 -> Perception-levelPerception cops@Kind.COps{cotile, coactor=Kind.Ops{okind}}-                configFov fid lid lvl@Level{lxsize, lysize} s =-  let hs = actorNotProjList (== fid) lid s-      cR b = preachable $ computeReachable cops configFov lvl b-      totalReachable = PerceptionReachable $ concatMap cR hs-      -- TODO: give actors light sources explicitly or alter vision.+levelPerception cops litHere actorEqpBody fovMode lvl@Level{lxsize, lysize} =+  let -- Dying actors included, to let them see their own demise.+      ours = filter (not . bproj . snd . fst) actorEqpBody+      ourR = preachable . reachableFromActor cops fovMode lvl+      totalReachable = PerceptionReachable $ concatMap ourR ours       pAndVicinity p = p : vicinity lxsize lysize p-      lightsBodies = map (\b -> (pAndVicinity $ bpos b, b)) hs-      light = concat $ map fst lightsBodies-      ptotal = computeVisible cotile totalReachable lvl light-      canSmell b = asmell $ okind $ bkind b-      -- We assume smell FOV radius is always 1, regardless of vision-      -- radius of the actor (if he can see at all).+      -- 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 Effect.EqpSlotAddSmell allAssocs+        in radius >= 2+      -- 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 (canSmell . snd) lightsBodies+               $ concat $ map fst $ filter (canSmellAround . snd) noctoBodies   in Perception ptotal psmell +-- | Calculate faction's perception of a level based on the lit tiles cache..+fidLidPerception :: Kind.COps -> FovMode -> PersLit+                 -> FactionId -> LevelId -> Level+                 -> Perception+fidLidPerception cops fovMode persLit fid lid lvl =+  let (litHere, bodyMap) = persLit EML.! lid+      actorEqpBody = EM.findWithDefault [] fid bodyMap+  in levelPerception cops litHere actorEqpBody fovMode lvl+ -- | Calculate perception of a faction.-factionPerception :: Kind.COps -> FovMode -> FactionId -> State-                  -> FactionPers-factionPerception cops configFov fid s =-  EM.mapWithKey (\lid lvl -> levelPerception cops configFov fid lid lvl s)-                $ sdungeon s+factionPerception :: FovMode -> PersLit -> FactionId -> State -> FactionPers+factionPerception fovMode persLit fid s =+  EM.mapWithKey (fidLidPerception (scops s) fovMode persLit fid) $ sdungeon s  -- | Calculate the perception of the whole dungeon.-dungeonPerception :: Kind.COps -> FovMode -> State -> Pers-dungeonPerception cops configFov s =-  let f fid _ = factionPerception cops configFov fid s+dungeonPerception :: FovMode -> State -> StateServer -> Pers+dungeonPerception fovMode s ser =+  let persLit = litInDungeon fovMode s ser+      f fid _ = factionPerception fovMode persLit fid s   in EM.mapWithKey f $ sfactionD s --- | A position can be directly lit by an ambient shine or a weak, portable--- light source, e.g,, carried by a hero. (Only lights of radius 0--- are considered for now and it's assumed they do not reveal hero's position.--- TODO: change this to be radius 1 noctovision and introduce stronger--- light sources that show more but make the hero visible.)--- A position is visible if it's reachable and either directly lit--- or adjacent to one that is at once directly lit and reachable.--- The last condition approximates being--- on the same side of obstacles as the light source.--- The approximation is not exact for multiple heroes, but the discrepancy--- can be attributed to deduction based on combined vague visual hints,--- e.g., if I don't see the reachable light seen by another hero,--- there must be a wall in-between. Stray rays indicate doors,--- moving shadows indicate monsters, etc.-computeVisible :: Kind.Ops TileKind -> PerceptionReachable-               -> Level -> [Point] -> PerceptionVisible-computeVisible cotile PerceptionReachable{preachable} lvl lights =-  let isVisible pos = Tile.isLit cotile (lvl `at` pos)-  in PerceptionVisible $ ES.fromList $ lights ++ filter isVisible preachable+-- | Compute positions visible (reachable and seen) by the party.+-- A position can be directly lit by an ambient shine or by a weak, portable+-- 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+               -> PerceptionVisible+visibleOnLevel Kind.COps{cotile}+               PerceptionReachable{preachable} PerceptionLit{plit}+               nocto lvl =+  let isVisible pos = Tile.isLit cotile (lvl `at` pos) || pos `ES.member` plit+  in PerceptionVisible $ ES.fromList $ nocto ++ filter isVisible preachable --- | Reachable are all fields on a visually unblocked path--- from the hero position.-computeReachable :: Kind.COps -> FovMode -> Level -> Actor-                 -> PerceptionReachable-computeReachable Kind.COps{cotile, coactor=Kind.Ops{okind}}-                 configFov lvl body =-  let sight = asight $ okind $ bkind body-      fovMode = if sight then configFov else Blind-      ppos = bpos body-      scan = fullscan cotile fovMode ppos lvl-  in PerceptionReachable scan+-- | Compute positions reachable by the actor. Reachable are all fields+-- on a visually unblocked path from the actor position.+reachableFromActor :: Kind.COps -> FovMode -> Level+                   -> ((ActorId, Actor), [ItemFull])+                   -> PerceptionReachable+reachableFromActor Kind.COps{cotile} fovMode lvl ((_, body), allItems) =+  let sumSight = sumSlotNoFilter Effect.EqpSlotAddSight allItems+      radius = min (fromIntegral $ bcalm body `div` (5 * oneM)) sumSight+  in PerceptionReachable $ fullscan cotile fovMode radius (bpos body) lvl +-- | 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+-- his own light (but others, from his or other factions, possibly do).+litByItems :: Kind.COps -> FovMode -> Level+           -> [(Point, [ItemFull])]+           -> PerceptionLit+litByItems Kind.COps{cotile} fovMode lvl allItems =+  let litPos :: (Point, [ItemFull]) -> [Point]+      litPos (p, is) =+        let radius = sumSlotNoFilter Effect.EqpSlotAddLight is+            scan = fullscan cotile fovMode radius p lvl+            -- 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++-- | Compute all lit positions in the dungeon+litInDungeon :: FovMode -> State -> StateServer -> PersLit+litInDungeon fovMode s ser =+  let cops = scops s+      itemsInActors :: Level -> EM.EnumMap FactionId ActorEqpBody+      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 (sdisco ser) (sdiscoAE 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, k)) =+              itemToFull cops (sdisco ser) (sdiscoAE ser) iid item k+            processPos (p, bag) =+              (p, map iToFull $ bagAssocsK s bag)+        in map processPos $ EM.assocs $ lfloor lvl+      -- Note that an actor can be blind or a projectile,+      -- 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 lvl =+        let bodyMap = itemsInActors lvl+            allBodies = concat $ EM.elems bodyMap+            actorItems = map (\((_, b), iis) -> (bpos b, iis)) allBodies+            floorItems = itemsOnFloor lvl+            allItems = floorItems ++ actorItems+        in (litByItems cops fovMode lvl allItems, bodyMap)+      litLvl (lid, lvl) = (lid, litOnLevel lvl)+  in EML.fromDistinctAscList $ map litLvl $ EM.assocs $ sdungeon s+ -- | Perform a full scan for a given position. Returns the positions -- that are currently in the field of view. The Field of View--- algorithm to use, passed in the second argument, is set in the config file.+-- algorithm to use is passed in the second argument. -- The actor's own position is considred reachable by him. fullscan :: Kind.Ops TileKind  -- ^ tile content, determines clear tiles          -> FovMode            -- ^ scanning mode+         -> Int                -- ^ scanning radius          -> Point              -- ^ position of the spectator          -> Level              -- ^ the map that is scanned          -> [Point]-fullscan cotile fovMode spectatorPos lvl = spectatorPos :-  case fovMode of+fullscan cotile fovMode radius spectatorPos lvl =+  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 r ->-      concatMap (\tr -> map tr (Digital.scan r (isCl . tr))) tr4-    Blind ->  -- all actors feel adjacent positions (for easy exploration)-      let radiusOne = 1-      in concatMap (\tr -> map tr (Digital.scan radiusOne (isCl . tr))) tr4+    Digital ->+      concatMap (\tr -> map tr (Digital.scan (radius - 1) (isCl . tr))) tr4  where   isCl :: Point -> Bool   isCl = Tile.isClear cotile . (lvl `at`)
Game/LambdaHack/Server/Fov/Common.hs view
@@ -1,5 +1,5 @@ -- | Common definitions for the Field of View algorithms.--- See <https://github.com/kosmikus/LambdaHack/wiki/Fov-and-los>+-- See <https://github.com/LambdaHack/LambdaHack/wiki/Fov-and-los> -- for some more context and references. module Game.LambdaHack.Server.Fov.Common   ( -- * Current scan parameters
Game/LambdaHack/Server/Fov/Digital.hs view
@@ -12,10 +12,10 @@  -- | Calculates the list of tiles, in @Bump@ coordinates, visible from (0, 0), -- within the given sight range.-scan :: Distance        -- ^ visiblity radius+scan :: Distance        -- ^ visiblity distance      -> (Bump -> Bool)  -- ^ clear tile predicate      -> [Bump]-scan r isClear =+scan r isClear = assert (r > 0 `blame` r) $   -- The scanned area is a square, which is a sphere in the chessboard metric.   dscan 1 ( (Line (B 1 0) (B (-r) r), [B 0 0])           , (Line (B 0 0) (B (r+1) r), [B 1 0]) )@@ -77,7 +77,7 @@  -- | Compare steepness of @(p1, f)@ and @(p2, f)@. -- Debug: Verify that the results of 2 independent checks are equal.-dsteeper :: Bump ->  Bump -> Bump -> Bool+dsteeper :: Bump -> Bump -> Bump -> Bool {-# INLINE dsteeper #-} dsteeper f p1 p2 =   assert (res == debugSteeper f p1 p2) res
Game/LambdaHack/Server/Fov/Permissive.hs view
@@ -83,7 +83,7 @@  -- | Compare steepness of @(p1, f)@ and @(p2, f)@. -- Debug: Verify that the results of 2 independent checks are equal.-dsteeper :: Bump ->  Bump -> Bump -> Bool+dsteeper :: Bump -> Bump -> Bump -> Bool dsteeper f p1 p2 =   assert (res == debugSteeper f p1 p2) res  where res = steeper f p1 p2
+ Game/LambdaHack/Server/HandleEffectServer.hs view
@@ -0,0 +1,817 @@+{-# LANGUAGE TupleSections #-}+-- | Handle effects (most often caused by requests sent by clients).+module Game.LambdaHack.Server.HandleEffectServer+  ( applyItem, itemEffect, itemEffectAndDestroy, effectsSem+  , dropEqpItem, armorHurtBonus+  ) where++import Control.Exception.Assert.Sugar+import Control.Monad+import Data.Bits (xor)+import qualified Data.EnumMap.Strict as EM+import Data.Key (mapWithKeyM_)+import Data.Maybe+import Data.Text (Text)+import qualified NLP.Miniutter.English as MU++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Dice as Dice+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.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.Point+import Game.LambdaHack.Common.Random+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 Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Server.CommonServer+import Game.LambdaHack.Server.ItemServer+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.PeriodicServer+import Game.LambdaHack.Server.StartServer+import Game.LambdaHack.Server.State++-- + Semantics of effects++applyItem :: (MonadAtomic m, MonadServer m)+          => ActorId -> ItemId -> CStore -> m ()+applyItem aid iid cstore = do+  itemToF <- itemToFullServer+  bag <- getsState $ getActorBag aid cstore+  let k = bag EM.! iid+      itemFull = itemToF iid k+  execSfxAtomic $ SfxActivate aid iid 1+  itemEffectAndDestroy aid aid iid itemFull cstore++itemEffectAndDestroy :: (MonadAtomic m, MonadServer m)+                     => ActorId -> ActorId -> ItemId -> ItemFull -> CStore+                     -> m ()+itemEffectAndDestroy source target iid itemFull cstore = do+  -- We have to destroy the item before the effect affects the item+  -- or the actor holding it or standing on it (later on we could+  -- lose track of the item and wouldn't be able to destroy it) .+  -- This is OK, because we don't remove the item type from various+  -- item dictionaries, just an individual copy from the container,+  -- so, e.g., the item can be identified after it's removed.+  let item = itemBase itemFull+      durable = Effect.Durable `elem` jfeature item+      periodic = isJust $ strengthFromEqpSlot Effect.EqpSlotPeriodic itemFull+      c = CActor source cstore+  unless (durable && periodic) $ do+    when (not durable) $+      execUpdAtomic $ UpdLoseItem iid item 1 c+    triggered <- itemEffect source target iid itemFull False False+    -- 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).+    when (not triggered && not durable) $+      execUpdAtomic $ UpdSpotItem iid item 1 c++-- | The source actor affects the target actor, with a given item.+-- If any of the effect effect fires up, the item gets identified. This function+-- is mutually recursive with @effect@ and so it's a part of @Effect@+-- semantics.+itemEffect :: (MonadAtomic m, MonadServer m)+           => ActorId -> ActorId -> ItemId -> ItemFull -> Bool -> Bool+           -> m Bool+itemEffect source target iid itemFull onSmash periodic = do+  case itemDisco itemFull of+    Just ItemDisco{itemKindId, itemAE=Just ItemAspectEffect{jeffects}} -> do+      let effs | onSmash = strengthOnSmash itemFull+               | otherwise = jeffects+      triggered <- effectsSem effs source target periodic+      -- 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+        execUpdAtomic $ UpdDiscover (blid postb) (bpos postb)+                                    iid itemKindId seed+      return triggered+    _ -> assert `failure` (source, target, iid, itemFull)++effectsSem :: (MonadAtomic m, MonadServer m)+           => [Effect.Effect Int] -> ActorId -> ActorId -> Bool+           -> m Bool+effectsSem effects source target periodic = do+  trs <- mapM (\ef -> effectSem ef source target) effects+  let triggered = or trs+  sb <- getsState $ getActorBody source+  -- Announce no effect, which is rare and wastes time, so noteworthy.+  unless (triggered  -- some effect triggered, so feedback comes from them+          || null effects  -- no effects present, no feedback needed+          || periodic  -- don't spam from fizzled periodic effects+          || bproj sb) $  -- don't spam, projectiles can be very numerous+    execSfxAtomic $ SfxEffect (bfid sb) target $ Effect.NoEffect ""+  return triggered++-- | The source actor affects the target actor, with a given effect and power.+-- Both actors are on the current level and can be the same actor.+-- The boolean result indicates if the effect actually fired up,+-- as opposed to fizzled.+effectSem :: (MonadAtomic m, MonadServer m)+          => Effect.Effect Int -> ActorId -> ActorId+          -> m Bool+effectSem effect source target = do+  sb <- getsState $ getActorBody source+  -- @execSfx@ usually comes last in effect semantics, but not always+  -- and we are likely to introduce more variety.+  let execSfx = execSfxAtomic $ SfxEffect (bfid sb) target effect+  case effect of+    Effect.NoEffect _ -> return False+    Effect.RefillHP p -> effectRefillHP execSfx p source target+    Effect.Hurt nDm -> effectHurt nDm source target+    Effect.RefillCalm p -> effectRefillCalm execSfx p target+    Effect.Dominate -> effectDominate source target+    Effect.Impress -> effectImpress execSfx source target+    Effect.CallFriend p -> effectCallFriend p source target+    Effect.Summon freqs p -> effectSummon freqs p source target+    Effect.CreateItem p -> effectCreateItem p target+    Effect.ApplyPerfume -> effectApplyPerfume execSfx target+    Effect.Burn p -> effectBurn execSfx p source target+    Effect.Ascend p -> effectAscend execSfx p source target+    Effect.Escape{} -> effectEscape target+    Effect.Paralyze p -> effectParalyze execSfx p target+    Effect.InsertMove p -> effectInsertMove execSfx p target+    Effect.DropBestWeapon -> effectDropBestWeapon execSfx target+    Effect.DropEqp symbol hit -> effectDropEqp execSfx hit target symbol+    Effect.SendFlying tmod ->+      effectSendFlying execSfx tmod source target Nothing+    Effect.PushActor tmod ->+      effectSendFlying execSfx tmod source target (Just True)+    Effect.PullActor tmod ->+      effectSendFlying execSfx tmod source target (Just False)+    Effect.Teleport p -> effectTeleport execSfx p target+    Effect.PolyItem cstore -> effectPolyItem execSfx cstore target+    Effect.Identify cstore -> effectIdentify execSfx cstore target+    Effect.ActivateInv symbol -> effectActivateInv execSfx target symbol+    Effect.Explode t -> effectExplode execSfx t target+    Effect.OneOf l -> effectOneOf l source target+    Effect.OnSmash _ -> return False  -- ignored under normal circumstances+    Effect.TimedAspect{} -> return False  -- TODO++-- + Individual semantic functions for effects++-- ** RefillHP++effectRefillHP :: (MonadAtomic m, MonadServer m)+           => m () -> Int -> ActorId -> ActorId -> m Bool+effectRefillHP execSfx power source target = do+  tb <- getsState $ getActorBody target+  hpMax <- sumOrganEqpServer Effect.EqpSlotAddMaxHP target+  let deltaHP = min (xM power) (max 0 $ xM hpMax - bhp tb)+  if deltaHP == 0+    then return False+    else do+      execUpdAtomic $ UpdRefillHP target deltaHP+      when (deltaHP < 0 && source /= target && not (bproj tb)) $+        halveCalm target+      execSfx+      return True++halveCalm :: (MonadAtomic m, MonadServer m)+          => ActorId -> m ()+halveCalm target = do+  tb <- getsState $ getActorBody target+  activeItems <- activeItemsServer target+  let calmMax = sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems+      calmUpperBound = if hpTooLow tb activeItems+                       then 0  -- to trigger domination, etc.+                       else xM calmMax `div` 2+      deltaCalm = min minusTwoM (calmUpperBound - bcalm tb)+  -- HP loss decreases Calm by at least minusTwoM, to overcome Calm regen,+  -- when far from shooting foe and to avoid "hears something",+  -- which is emitted for decrease minusM.+  execUpdAtomic $ UpdRefillCalm target deltaCalm++-- ** Hurt++effectHurt :: (MonadAtomic m, MonadServer m)+           => Dice.Dice -> ActorId -> ActorId+           -> m Bool+effectHurt nDm source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody 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)+      deltaHP = - (max oneM  -- at least 1 HP taken+                   $ fromIntegral mult * xM n `divUp` (100 * 100))+      deltaDiv = fromIntegral $ deltaHP `divUp` oneM+  -- Damage the target.+  execUpdAtomic $ UpdRefillHP target deltaHP+  when (source /= target && not (bproj tb)) $ halveCalm target+  execSfxAtomic $ SfxEffect (bfid sb) target $+    if source == target+    then Effect.RefillHP deltaDiv  -- no SfxStrike, so treat as any heal/wound+    else Effect.Hurt (Dice.intToDice deltaDiv)  -- avoid spam; SfxStrike sent+  return True++armorHurtBonus :: (MonadAtomic m, MonadServer m)+               => ActorId -> ActorId+               -> m Int+armorHurtBonus source target = do+  sactiveItems <- activeItemsServer source+  tactiveItems <- activeItemsServer target+  sb <- getsState $ getActorBody source+  return $! if bproj sb+            then sumSlotNoFilter Effect.EqpSlotAddHurtRanged sactiveItems+                 - sumSlotNoFilter Effect.EqpSlotAddArmorRanged tactiveItems+            else sumSlotNoFilter Effect.EqpSlotAddHurtMelee sactiveItems+                 - sumSlotNoFilter Effect.EqpSlotAddArmorMelee tactiveItems++-- ** RefillCalm++effectRefillCalm ::  (MonadAtomic m, MonadServer m)+           => m () -> Int -> ActorId -> m Bool+effectRefillCalm execSfx power target = do+  tb <- getsState $ getActorBody target+  calmMax <- sumOrganEqpServer Effect.EqpSlotAddMaxCalm target+  let deltaCalm = min (xM power) (max 0 $ xM calmMax - bcalm tb)+  if deltaCalm == 0+    then return False+    else do+      execUpdAtomic $ UpdRefillCalm target deltaCalm+      execSfx+      return True++-- ** Dominate++effectDominate :: (MonadAtomic m, MonadServer m)+               => ActorId -> ActorId -> m Bool+effectDominate source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  if bproj tb then+    return False+  else if bfid tb == bfid sb then+    effectSem Effect.Impress source target+  else+    dominateFidSfx (bfid sb) target++-- ** Impress++effectImpress :: (MonadAtomic m, MonadServer m)+              => m () -> ActorId -> ActorId -> m Bool+effectImpress execSfx source target = do+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  if boldfid tb == bfid sb || bproj tb then+    return False+  else do+    execSfx+    execUpdAtomic $ UpdOldFidActor target (boldfid tb) (bfid sb)+    return True++-- ** SummonFriend++effectCallFriend :: (MonadAtomic m, MonadServer m)+                   => Int -> ActorId -> ActorId+                   -> m Bool+effectCallFriend power source target = assert (power > 0) $ do+  -- Obvious effect, nothing announced.+  Kind.COps{cotile} <- getsState scops+  sb <- getsState $ getActorBody source+  activeItems <- activeItemsServer source+  let legal = source == target+              && hpEnough sb activeItems+              && bhp sb >= xM 10  -- prevent spam from regenerating wimps+  if not legal then return False+  else do+    let hpMax = max 1 $ sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems+        deltaHP = - xM hpMax `div` 3+    execUpdAtomic $ UpdRefillHP source deltaHP+    let validTile t = not $ Tile.hasFeature cotile F.NoActor t+        lid = blid sb+    ps <- getsState $ nearbyFreePoints validTile (bpos sb) lid+    time <- getsState $ getLocalTime lid+    recruitActors (take power ps) lid time (bfid sb)++-- ** Summon++effectSummon :: (MonadAtomic m, MonadServer m)+             => Freqs -> Int -> ActorId -> ActorId -> m Bool+effectSummon actorFreq power source target = assert (power > 0) $ do+  -- Obvious effect, nothing announced.+  Kind.COps{cotile} <- getsState scops+  sb <- getsState $ getActorBody source+  activeItems <- activeItemsServer source+  let legal = source == target+              && (bproj sb+                  || calmEnough sb activeItems+                     && bcalm sb >= xM 10)+  if not legal then return False+  else do+    let calmMax = max 1 $ sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems+        deltaCalm = - xM calmMax `div` 3+    unless (bproj sb) $ execUpdAtomic $ UpdRefillCalm source deltaCalm+    let validTile t = not $ Tile.hasFeature cotile F.NoActor t+    ps <- getsState $ nearbyFreePoints validTile (bpos sb) (blid sb)+    localTime <- getsState $ getLocalTime (blid sb)+    -- Make sure summoned actors start acting after the summoner.+    let sourceTime = timeShift localTime $ ticksPerMeter $ bspeed sb activeItems+        afterTime = timeShift sourceTime $ Delta timeClip+    bs <- forM (take power ps) $ \p -> do+      maid <- addAnyActor actorFreq (blid sb) afterTime (Just p)+      case maid of+        Nothing ->+          -- Don't make this item useless.+          effectSem (Effect.CallFriend 1) source target+        Just aid -> do+          b <- getsState $ getActorBody aid+          mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD+          when (isNothing mleader) $+            execUpdAtomic $ UpdLeadFaction (bfid b) Nothing (Just aid)+          return True+    return $! or bs++-- ** CreateItem++effectCreateItem :: (MonadAtomic m, MonadServer m)+                 => Int -> ActorId -> m Bool+effectCreateItem power target = assert (power > 0) $ do+  -- Obvious effect, nothing announced.+  tb <- getsState $ getActorBody target+  void $ createItems power (bpos tb) (blid tb)+  return True++-- ** ApplyPerfume++effectApplyPerfume :: (MonadAtomic m, MonadServer m)+                   => m () -> ActorId -> m Bool+effectApplyPerfume execSfx target = do+  tb <- getsState $ getActorBody target+  Level{lsmell} <- getLevel $ blid tb+  let f p fromSm =+        execUpdAtomic $ UpdAlterSmell (blid tb) p (Just fromSm) Nothing+  mapWithKeyM_ f lsmell+  execSfx+  return True++-- ** Burn++effectBurn :: (MonadAtomic m, MonadServer m)+           => m () -> Int -> ActorId -> ActorId+           -> m Bool+effectBurn execSfx power source target = do+  -- Damage from both impact and fire.+  void $ effectHurt (Dice.intToDice $ 2 * power) source target+  execSfx+  return True++-- ** Ascend++-- Note that projectiles can be teleported, too, for extra fun.+effectAscend :: (MonadAtomic m, MonadServer m)+             => m () -> Int -> ActorId -> ActorId -> m Bool+effectAscend execSfx k source aid = do+  b1 <- getsState $ getActorBody aid+  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."+    let effect = Effect.Teleport 30  -- powerful teleport+    effectSem effect source aid+  else do+    let switch1 = void $ switchLevels1 ((aid, b1), ais1)+        switch2 = do+          -- Make the intiator of the stair move the leader,+          -- to let him clear the stairs for other to follow.+          let mlead = Just aid+          -- Move the actor to where the inhabitants were, if any.+          switchLevels2 lid2 pos2 ((aid, 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+          return ()+    -- The actor will be added to the new level, but there can be other actors+    -- at his new position.+    inhabitants <- getsState $ posToActors pos2 lid2+    case inhabitants of+      [] -> do+        switch1+        switch2+      ((_, b2), _) : _ -> do+        -- Alert about the switch.+        let subjects = map (partActor . snd . fst) inhabitants+            subject = MU.WWandW subjects+            verb = "be pushed to another level"+            msg2 = makeSentence [MU.SubjectVerbSg subject verb]+        -- Only tell one player, even if many actors, because then+        -- they are projectiles, so not too important.+        execSfxAtomic $ SfxMsgFid (bfid b2) msg2+        -- Move the actor out of the way.+        switch1+        -- Move the inhabitant out of the way and to where the actor was.+        let moveInh inh = do+              -- Preserve old the leader, since the actor is pushed, so possibly+              -- has nothing worhwhile to do on the new level (and could try+              -- to switch back, if made a leader, leading to a loop).+              inhMLead <- switchLevels1 inh+              switchLevels2 lid1 pos1 inh inhMLead+        mapM_ moveInh inhabitants+        -- Move the actor to his destination.+        switch2+    execSfx+    return True++switchLevels1 :: MonadAtomic m+              => ((ActorId, Actor), [(ItemId, Item)]) -> m (Maybe ActorId)+switchLevels1 ((aid, bOld), ais) = do+  let side = bfid bOld+  mleader <- getsState $ gleader . (EM.! side) . sfactionD+  -- Prevent leader pointing to a non-existing actor.+  mlead <-+    if not (bproj bOld) && isJust mleader then do+      execUpdAtomic $ UpdLeadFaction side mleader Nothing+      return mleader+    else return Nothing+  -- Remove the actor from the old level.+  -- Onlookers see somebody disappear suddenly.+  -- @UpdDestroyActor@ is too loud, so use @UpdLoseActor@ instead.+  execUpdAtomic $ UpdLoseActor aid bOld ais+  return mlead++switchLevels2 :: MonadAtomic m+              => LevelId -> Point+              -> ((ActorId, Actor), [(ItemId, Item)]) -> Maybe ActorId+              -> m ()+switchLevels2 lidNew posNew ((aid, bOld), ais) mlead = do+  let lidOld = blid bOld+      side = bfid bOld+  assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) skip+  -- Sync the actor time with the level time.+  timeOld <- getsState $ getLocalTime lidOld+  timeLastVisited <- getsState $ getLocalTime lidNew+  -- This time calculation may cause a double move of a foe of the same+  -- speed, but this is OK --- the foe didn't have a chance to move+  -- before, because the arena went inactive, so he moves now one more time.+  let delta = btime bOld `timeDeltaToFrom` timeOld+      bNew = bOld { blid = lidNew+                  , btime = timeShift timeLastVisited delta+                  , bpos = posNew+                  , boldpos = posNew  -- new level, new direction+                  , boldlid = lidOld }  -- record old level+  -- Materialize the actor at the new location.+  -- Onlookers see somebody appear suddenly. The actor himself+  -- sees new surroundings and has to reset his perception.+  execUpdAtomic $ UpdCreateActor aid bNew ais+  when (isJust mlead) $ execUpdAtomic $ UpdLeadFaction side Nothing mlead++-- ** Escape++-- | The faction leaves the dungeon.+effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> m Bool+effectEscape target = do+  -- Obvious effect, nothing announced.+  b <- getsState $ getActorBody target+  let fid = bfid b+  fact <- getsState $ (EM.! fid) . sfactionD+  if not (keepArenaFact fact) || bproj b then+    return False+  else do+    deduceQuits b $ Status Escape (fromEnum $ blid b) ""+    return True++-- ** Paralyze++-- | Advance target actor time by this many time clips. Not by actor moves,+-- to hurt fast actors more.+effectParalyze :: (MonadAtomic m, MonadServer m)+               => m () -> Int -> ActorId -> m Bool+effectParalyze execSfx p target = assert (p > 0) $ do+  b <- getsState $ getActorBody target+  if bproj b || bhp b <= 0+    then return False+    else do+      let t = timeDeltaScale (Delta timeClip) p+      execUpdAtomic $ UpdAgeActor target t+      execSfx+      return True++-- ** InsertMove++-- TODO: Replace with SpeedBurst that lasts just 1 turn,+-- but make sure the cost of this item activation is vs previous speed+-- | Give target actor the given number of extra moves. Don't give+-- an absolute amount of time units, to benefit slow actors more.+effectInsertMove :: (MonadAtomic m, MonadServer m)+                 => m () -> Int -> ActorId -> m Bool+effectInsertMove execSfx p target = assert (p > 0) $ do+  b <- getsState $ getActorBody target+  activeItems <- activeItemsServer target+  let tpm = ticksPerMeter $ bspeed b activeItems+      t = timeDeltaScale tpm (-p)+  execUpdAtomic $ UpdAgeActor target t+  execSfx+  return True++-- ** DropBestWeapon++-- | Make the target actor drop his best weapon (stack).+effectDropBestWeapon :: (MonadAtomic m, MonadServer m)+                     => m () -> ActorId -> m Bool+effectDropBestWeapon execSfx target = do+  allAssocs <- fullAssocsServer target [CEqp]+  case strongestSlotNoFilter Effect.EqpSlotWeapon allAssocs of+    (_, (iid, _)) : _ -> do+      b <- getsState $ getActorBody target+      let k = beqp b EM.! iid+      dropEqpItem target b False iid k+      execSfx+      return True+    [] ->+      return False++-- | Drop a single actor's item. Note that if there multiple copies,+-- at most one explodes to avoid excessive carnage and UI clutter+-- (let's say, the multiple explosions interfere with each other or perhaps+-- larger quantities of explosives tend to be packaged more safely).+dropEqpItem :: (MonadAtomic m, MonadServer m)+            => ActorId -> Actor -> Bool -> ItemId -> Int -> m ()+dropEqpItem aid b hit iid k = do+  item <- getsState $ getItemBody iid+  itemToF <- itemToFullServer+  let container = CActor aid CEqp+      fragile = Effect.Fragile `elem` jfeature item+      durable = Effect.Durable `elem` jfeature item+      isDestroyed = hit && not durable || bproj b && fragile+      itemFull = itemToF iid k+  if isDestroyed then do+    -- Feedback from hit, or it's shrapnel, so no @UpdDestroyItem@.+    execUpdAtomic $ UpdLoseItem iid item k container+    void $ itemEffect aid aid iid itemFull True False+  else do+    mvCmd <- generalMoveItem iid k (CActor aid CEqp)+                                   (CActor aid CGround)+    mapM_ execUpdAtomic mvCmd++-- ** DropEqp++-- | Make the target actor drop all items in his equiment with the given symbol+-- (not just a random one, or cluttering equipment with rubbish+-- would be beneficial).+effectDropEqp :: (MonadAtomic m, MonadServer m)+              => m () -> Bool -> ActorId -> Char -> m Bool+effectDropEqp execSfx hit target symbol = do+  b <- getsState $ getActorBody target+  effectTransformEqp execSfx target symbol CEqp $+    dropEqpItem target b hit++effectTransformEqp :: forall m. (MonadAtomic m, MonadServer m)+                   => m () -> ActorId -> Char -> CStore+                   -> (ItemId -> Int -> m ())+                   -> m Bool+effectTransformEqp execSfx target symbol cstore m = do+  let hasSymbol (iid, _) = do+        item <- getsState $ getItemBody iid+        return $! jsymbol item == symbol+  assocsCStore <- getsState $ EM.assocs . getActorBag target cstore+  is <- if symbol == ' '+        then return assocsCStore+        else filterM hasSymbol assocsCStore+  if null is+    then return False+    else do+      mapM_ (uncurry m) is+      execSfx+      return True++-- ** SendFlying++-- | Shend the target actor flying like a projectile. The arguments correspond+-- to @ToThrow@ and @Linger@ properties of items. If the actors are adjacent,+-- the vector is directed outwards, if no, inwards, if it's the same actor,+-- boldpos is used, if it can't, a random outward vector of length 10+-- is picked.+effectSendFlying :: (MonadAtomic m, MonadServer m)+                 => m () -> Effect.ThrowMod+                 -> ActorId -> ActorId -> Maybe Bool+                 -> m Bool+effectSendFlying execSfx Effect.ThrowMod{..} source target modePush = do+  v <- sendFlyingVector source target modePush+  Kind.COps{cotile} <- getsState scops+  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+    Nothing -> assert `failure` (fpos, tb)+    Just [] -> assert `failure` "projecting from the edge of level"+                      `twith` (fpos, tb)+    Just (pos : rest) -> do+      let t = lvl `at` pos+      if not $ Tile.isWalkable cotile t+        then return False  -- supported by a wall+        else do+          weightAssocs <- fullAssocsServer target [CInv, CEqp, COrgan]+          let weight = sum $ map (jweight . itemBase . snd) weightAssocs+              path = bpos tb : pos : rest+              (trajectory, (speed, _)) =+                computeTrajectory weight throwVelocity throwLinger path+              ts = Just (trajectory, speed)+          unless (btrajectory tb == ts) $+            execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts+          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 boldpos sb == bpos sb then rndToAction $ do+      z <- randomR (-10, 10)+      oneOf [Vector 10 z, Vector (-10) z, Vector z 10, Vector z (-10)]+    else+      return $! vectorToFrom (bpos sb) (boldpos sb)+  else do+    tb <- getsState $ getActorBody target+    let (sp, tp) = if adjacent (bpos sb) (bpos tb)+                   then let pos = if chessDist (boldpos sb) (bpos tb)+                                     > chessDist (bpos sb) (bpos tb)+                                  then boldpos sb  -- avoid cardinal dir+                                  else bpos sb+                        in (pos, bpos tb)+                   else (bpos sb, bpos tb)+        pushV = vectorToFrom tp sp+        pullV = vectorToFrom sp tp+    return $! case modePush of+                Just True -> pushV+                Just False -> pullV+                Nothing | adjacent (bpos sb) (bpos tb) -> pushV+                Nothing -> pullV++-- ** Teleport++-- | Teleport the target actor.+-- Note that projectiles can be teleported, too, for extra fun.+effectTeleport :: (MonadAtomic m, MonadServer m)+               => m () -> Int -> ActorId -> m Bool+effectTeleport execSfx range target = do+  Kind.COps{cotile} <- getsState scops+  b <- getsState $ getActorBody target+  Level{ltile} <- getLevel (blid b)+  as <- getsState $ actorList (const True) (blid b)+  let spos = bpos b+      dMinMax delta pos =+        let d = chessDist spos pos+        in d >= range - delta && d <= range + delta+      dist delta pos _ = dMinMax delta pos+  tpos <- rndToAction $ findPosTry 200 ltile+    (\p t -> Tile.isWalkable cotile t+             && (not (dMinMax 9 p)  -- don't loop, very rare+                 || not (Tile.hasFeature cotile F.NoActor t)+                    && unoccupied as p))+    [ dist $ 1+    , dist $ 1 + range `div` 9+    , dist $ 1 + range `div` 7+    , dist $ 1 + range `div` 5+    , dist $ 5+    , dist $ 7+    ]+  if not (dMinMax 9 tpos) then+    return False  -- very rare+  else do+    execUpdAtomic $ UpdMoveActor target spos tpos+    execSfx+    return True++-- ** PolyItem++effectPolyItem :: (MonadAtomic m, MonadServer m)+               => m () -> CStore -> ActorId -> m Bool+effectPolyItem execSfx cstore target = do+  allAssocs <- fullAssocsServer target [cstore]+  case allAssocs of+    [] -> return False+    (iid, itemFull@ItemFull{..}) : _ -> case itemDisco of+      Just ItemDisco{itemKind} -> do+        let maxCount = Dice.maxDice $ icount itemKind+        if itemK >= maxCount+        then do+          let c = CActor target cstore+          execUpdAtomic $ UpdDestroyItem iid itemBase maxCount c+          execSfx+          effectCreateItem 1 target+        else do+          tb <- getsState $ getActorBody target+          execSfxAtomic $ SfxMsgFid (bfid tb) $+            "The purpose is served by" <+> tshow maxCount+            <+> "pieces of this item, not by" <+> tshow itemK <> "."+          return False+      _ -> assert `failure` (cstore, target, iid, itemFull)++-- ** Identify++effectIdentify :: (MonadAtomic m, MonadServer m)+               => m () -> CStore -> ActorId -> m Bool+effectIdentify execSfx cstore target = do+  allAssocs <- fullAssocsServer target [cstore]+  case allAssocs of+    [] -> return False+    (iid, itemFull@ItemFull{..}) : _ -> case itemDisco of+      Just ItemDisco{..} -> do+        -- TODO: use this (but faster, via traversing effects with 999)+        -- also to prevent sending any other UpdDiscover.+        let ided = Effect.Identified `elem` ifeature itemKind+            itemSecret = itemNoAE itemFull+            statsObvious = textAllAE False cstore itemFull+                           == textAllAE False cstore itemSecret+        if ided && statsObvious+          then return False+          else do+            execSfx+            tb <- getsState $ getActorBody target+            seed <- getsServer $ (EM.! iid) . sitemSeedD+            execUpdAtomic $ UpdDiscover (blid tb) (bpos tb) iid itemKindId seed+            return True+      _ -> assert `failure` (cstore, target, iid, itemFull)++-- ** ActivateInv++-- | Activate all activable 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+  effectTransformEqp execSfx target symbol CInv $ \iid _ ->+    applyItem target iid CInv++-- ** Explode++effectExplode :: (MonadAtomic m, MonadServer m)+              => m () -> Text -> ActorId -> m Bool+effectExplode execSfx cgroup target = do+  tb <- getsState $ getActorBody target+  let itemFreq = [(cgroup, 1)]+      container = CActor target CEqp+  m2 <- rollAndRegisterItem (blid tb) itemFreq container False+  let (iid, (ItemFull{..}, _)) = fromMaybe (assert `failure` cgroup) m2+      Point x y = bpos tb+      projectN k100 n = do+        -- We pick a point at the border, not inside, to have a uniform+        -- distribution for the points the line goes through at each distance+        -- from the source. Otherwise, e.g., the points on cardinal+        -- and diagonal lines from the source would be more common.+        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+            ps = take k $+              [ Point (x - 12) $ y + fuzz+              , Point (x - 12) $ y - fuzz+              , Point (x + 12) $ y + fuzz+              , Point (x + 12) $ y - fuzz+              , flip Point (y - 12) $ x + fuzz+              , flip Point (y - 12) $ x - fuzz+              , flip Point (y + 12) $ x + fuzz+              , flip Point (y + 12) $ x - fuzz+              ]+        forM_ ps $ \tpxy -> do+          let req = ReqProject tpxy k100 iid CEqp+          mfail <- projectFail target tpxy k100 iid CEqp True+          case mfail of+            Nothing -> return ()+            Just ProjectBlockTerrain -> return ()+            Just ProjectBlockActor | not $ bproj tb -> return ()+            Just failMsg -> execFailure target req failMsg+  -- All shrapnels bounce off obstacles many times before they destruct.+  forM_ [101..201] $ \k100 -> do+    bag2 <- getsState $ beqp . getActorBody target+    let mn2 = EM.lookup iid bag2+    maybe skip (projectN k100) mn2+  bag3 <- getsState $ beqp . getActorBody target+  let mn3 = EM.lookup iid bag3+  maybe skip (\k -> execUpdAtomic+                    $ UpdLoseItem iid itemBase k container) mn3+  execSfx+  return True  -- we avoid verifying that at least one projectile got off++-- ** OneOf++effectOneOf :: (MonadAtomic m, MonadServer m)+            => [Effect.Effect Int] -> ActorId -> ActorId -> m Bool+effectOneOf l source target = do+  ef <-  rndToAction $ oneOf l+  effectSem ef source target
+ Game/LambdaHack/Server/HandleRequestServer.hs view
@@ -0,0 +1,467 @@+{-# LANGUAGE GADTs #-}+-- | Semantics of request.+-- A couple of them do not take time, the rest does.+-- Note that since the results are atomic commands, which are executed+-- only later (on the server and some of the clients), all condition+-- are checkd by the semantic functions in the context of the state+-- before the server command. Even if one or more atomic actions+-- are already issued by the point an expression is evaluated, they do not+-- influence the outcome of the evaluation.+-- TODO: document+module Game.LambdaHack.Server.HandleRequestServer+  ( handleRequestAI, handleRequestUI, reqMove+  ) where++import Control.Applicative+import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+import Data.Maybe+import Data.Text (Text)++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.TileKind as TileKind+import Game.LambdaHack.Server.CommonServer+import Game.LambdaHack.Server.HandleEffectServer+import Game.LambdaHack.Server.ItemServer+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++-- | The semantics of server commands. The resulting actor id+-- is of the actor that carried out the request.+handleRequestAI :: (MonadAtomic m, MonadServer m)+                => FactionId -> ActorId -> RequestAI -> m ActorId+handleRequestAI fid aid cmd = case cmd of+  ReqAITimed cmdT -> handleRequestTimed aid cmdT >> return aid+  ReqAILeader aidNew cmd2 -> do+    switchLeader fid aidNew+    handleRequestAI fid aidNew cmd2+  ReqAIPong -> return aid++-- | The semantics of server commands. The resulting actor id+-- is of the actor that carried out the request. @Nothing@ means+-- the command took no time.+handleRequestUI :: (MonadAtomic m, MonadServer m)+                => FactionId -> RequestUI -> m (Maybe ActorId)+handleRequestUI fid cmd = case cmd of+  ReqUITimed cmdT -> do+    fact <- getsState $ (EM.! fid) . sfactionD+    let aid = fromMaybe (assert `failure` fact) $ gleader fact+    handleRequestTimed aid cmdT >> return (Just aid)+  ReqUILeader aidNew cmd2 -> do+    switchLeader fid aidNew+    handleRequestUI fid cmd2+  ReqUIGameRestart aid t d names ->+    reqGameRestart aid t d names >> return Nothing+  ReqUIGameExit aid d -> reqGameExit aid d >> return Nothing+  ReqUIGameSave -> reqGameSave >> return Nothing+  ReqUIAutomate -> reqAutomate fid >> return Nothing+  ReqUIPong _ -> return Nothing++handleRequestTimed :: (MonadAtomic m, MonadServer m)+                   => ActorId -> RequestTimed a -> m ()+handleRequestTimed aid cmd = case cmd of+  ReqMove target -> reqMove aid target+  ReqMelee target iid cstore -> reqMelee aid target iid cstore+  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+  ReqProject p eps iid cstore -> reqProject aid p eps iid cstore+  ReqApply iid cstore -> reqApply aid iid cstore+  ReqTrigger mfeat -> reqTrigger aid mfeat++switchLeader :: MonadAtomic m+             => FactionId -> ActorId -> m ()+switchLeader fid aidNew = do+  cops <- getsState scops+  fact <- getsState $ (EM.! fid) . sfactionD+  bPre <- getsState $ getActorBody aidNew+  let mleader = gleader fact+      leadAtoms = [UpdLeadFaction fid mleader (Just aidNew)]+  mapM_ execUpdAtomic leadAtoms+  assert (Just aidNew /= mleader+          && not (bproj bPre)+          && not (isAllMoveFact cops fact)+         `blame` (aidNew, bPre, fid, fact)) skip+  assert (bfid bPre == fid+          `blame` "client tries to move other faction actors"+          `twith` (aidNew, bPre, fid, fact)) skip++-- * ReqMove++-- 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.+addSmell :: (MonadAtomic m, MonadServer m) => ActorId -> m ()+addSmell aid = do+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  smellRadius <- sumOrganEqpServer Effect.EqpSlotAddSmell aid+  unless (bproj b || not (isHeroFact fact) || smellRadius > 0) $ do+    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)++-- | Actor moves or attacks.+-- Note that client may not be able to see an invisible monster+-- so it's the server that determines if melee took place, etc.+-- Also, only the server is authorized to check if a move is legal+-- and it needs full context for that, e.g., the initial actor position+-- to check if melee attack does not try to reach to a distant tile.+reqMove :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m ()+reqMove source dir = do+  cops <- 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+  -- We start by checking actors at the the target position.+  tgt <- getsState $ posToActor tpos lid+  case tgt of+    Just ((target, tb), _) | not (bproj sb && bproj tb) -> do  -- visible or not+      -- Projectiles are too small to hit each other.+      -- Attacking does not require full access, adjacency is enough.+      -- Here the only weapon of projectiles is picked, too.+      mweapon <- pickWeaponServer source+      case mweapon of+        Nothing -> reqWait source+        Just (wp, cstore) -> reqMelee source target wp cstore+    _+      | accessible cops lvl spos tpos -> do+          -- Movement requires full access.+          execUpdAtomic $ UpdMoveActor source spos tpos+          addSmell source+      | otherwise ->+          -- Client foolishly tries to move into blocked, boring tile.+          execFailure source (ReqMove dir) MoveNothing++-- * ReqMelee++-- | Resolves the result of an actor moving into another.+-- Actors on blocked positions can be attacked without any restrictions.+-- For instance, an actor embedded in a wall can be attacked from+-- an adjacent position. This function is analogous to projectGroupItem,+-- but for melee and not using up the weapon.+-- No problem if there are many projectiles at the spot. We just+-- attack the one specified.+reqMelee :: (MonadAtomic m, MonadServer m)+         => ActorId -> ActorId -> ItemId -> CStore -> m ()+reqMelee source target iid cstore = do+  itemToF <- itemToFullServer+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  let adj = checkAdjacent sb tb+      req = ReqMelee target iid cstore+  if source == target then execFailure source req MeleeSelf+  else if not adj then execFailure source req MeleeDistant+  else do+    let sfid = bfid sb+        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+    -- 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+      Nothing -> return ()+      Just (tra, speed) -> do+        execUpdAtomic $ UpdRefillHP source minusM+        unless (bproj sb || null tra) $+          -- Non-projectiles can't pierce, so terminate their flight.+          execUpdAtomic+          $ UpdTrajectory source (btrajectory sb) (Just ([], speed))+    -- Msgs inside itemEffect describe the target part.+    itemEffectAndDestroy source target iid (itemToF iid 1) cstore+    -- The only way to start a war is to slap an enemy. Being hit by+    -- and hitting projectiles count as unintentional friendly fire.+    let friendlyFire = bproj sb || bproj tb+        fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)+    unless (friendlyFire+            || isAtWar sfact tfid  -- already at war+            || isAllied sfact tfid  -- allies never at war+            || sfid == tfid) $+      execUpdAtomic $ UpdDiplFaction sfid tfid fromDipl War++-- * ReqDisplace++-- | Actor tries to swap positions with another.+reqDisplace :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()+reqDisplace source target = do+  cops <- getsState scops+  sb <- getsState $ getActorBody source+  tb <- getsState $ getActorBody target+  tfact <- getsState $ (EM.! bfid tb) . sfactionD+  let spos = bpos sb+      tpos = bpos tb+      adj = checkAdjacent sb tb+      atWar = isAtWar tfact (bfid sb)+      req = ReqDisplace target+  activeItems <- activeItemsServer target+  dEnemy <- getsState $ dispEnemy source target activeItems+  if not adj then execFailure source req DisplaceDistant+  else if atWar && not dEnemy+  then do+    mweapon <- pickWeaponServer source+    case mweapon of+      Nothing -> reqWait source+      Just (wp, cstore)  -> reqMelee source target wp cstore+        -- DisplaceDying, DisplaceSupported+  else do+    let lid = blid sb+    lvl <- getLevel lid+    -- Displacing requires full access.+    if accessible cops lvl spos tpos then do+      tgts <- getsState $ posToActors tpos lid+      case tgts of+        [] -> assert `failure` (source, sb, target, tb)+        [_] -> do+          execUpdAtomic $ UpdDisplaceActor source target+          addSmell source+          addSmell target+        _ -> execFailure source req DisplaceProjectiles+    else do+      -- Client foolishly tries to displace an actor without access.+      execFailure source req DisplaceAccess++-- * ReqAlter++-- | Search and/or alter the tile.+--+-- Note that if @serverTile /= freshClientTile@, @freshClientTile@+-- should not be alterable (but @serverTile@ may be).+reqAlter :: (MonadAtomic m, MonadServer m)+         => ActorId -> Point -> Maybe F.Feature -> m ()+reqAlter source tpos mfeat = do+  Kind.COps{cotile=cotile@Kind.Ops{okind, opick}} <- getsState scops+  sb <- getsState $ getActorBody source+  let lid = blid sb+      spos = bpos sb+      req = ReqAlter tpos mfeat+  if not $ adjacent spos tpos then execFailure source req AlterDistant+  else do+    lvl <- getLevel lid+    let serverTile = lvl `at` tpos+        freshClientTile = hideTile cotile 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)+          unless (toTile == serverTile) $ do+            execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile+            case (Tile.isExplorable cotile serverTile,+                  Tile.isExplorable cotile toTile) of+              (False, True) -> execUpdAtomic $ UpdAlterClear lid 1+              (True, False) -> execUpdAtomic $ UpdAlterClear lid (-1)+              _ -> return ()+        feats = case mfeat of+          Nothing -> TileKind.tfeature $ okind serverTile+          Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]+          Just _ -> []+        toAlter feat =+          case feat of+            F.OpenTo tgroup -> Just tgroup+            F.CloseTo tgroup -> Just tgroup+            F.ChangeTo tgroup -> Just tgroup+            _ -> Nothing+        groupsToAlterTo = mapMaybe toAlter feats+    as <- getsState $ actorList (const True) lid+    if null groupsToAlterTo && serverTile == freshClientTile then+      -- Neither searching nor altering possible; silly client.+      execFailure source req AlterNothing+    else do+      if EM.null $ lvl `atI` tpos then+        if unoccupied as tpos then do+          when (serverTile /= freshClientTile) $ do+            -- Search, in case some actors (of other factions?)+            -- don't know this tile.+            execUpdAtomic $ UpdSearchTile source tpos freshClientTile serverTile+          maybe skip changeTo $ listToMaybe groupsToAlterTo+            -- TODO: pick another, if the first one void+          -- Perform an effect, if any permitted.+          void $ triggerEffect source feats+        else execFailure source req AlterBlockActor+      else execFailure source req AlterBlockItem++-- * ReqWait++-- | Do nothing.+--+-- Something is sometimes done in 'LoopAction.setBWait'.+reqWait :: MonadAtomic m => ActorId -> m ()+reqWait _ = return ()++-- * ReqMoveItem++reqMoveItem :: (MonadAtomic m, MonadServer m)+            => ActorId -> ItemId -> Int -> CStore -> CStore -> m ()+reqMoveItem aid iid k fromCStore toCStore = do+  b <- getsState $ getActorBody aid+  activeItems <- activeItemsServer aid+  let moveItem = do+        when (fromCStore == CGround) $ do+          seed <- getsServer $ (EM.! iid) . sitemSeedD+          execUpdAtomic $ UpdDiscoverSeed (blid b) (bpos b) iid seed+        upds <- generalMoveItem iid k (CActor aid fromCStore)+                                      (CActor aid toCStore)+        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 do+    if calmEnough b activeItems then moveItem+    else execFailure aid req ItemNotCalm++-- * ReqProject++reqProject :: (MonadAtomic m, MonadServer m)+           => ActorId    -- ^ actor projecting the item (is on current lvl)+           -> Point      -- ^ target position of the projectile+           -> Int        -- ^ digital line parameter+           -> ItemId     -- ^ the item to be projected+           -> CStore     -- ^ whether the items comes from floor or inventory+           -> m ()+reqProject source tpxy eps iid cstore = assert (cstore /= CSha) $ do+  mfail <- projectFail source tpxy eps iid cstore False+  let req = ReqProject tpxy eps iid cstore+  maybe skip (execFailure source req) mfail++-- * ReqApply++reqApply :: (MonadAtomic m, MonadServer m)+         => ActorId  -- ^ actor applying the item (is on current level)+         -> ItemId   -- ^ the item to be applied+         -> CStore   -- ^ the location of the item+         -> m ()+reqApply aid iid cstore = assert (cstore /= CSha) $ do+  bag <- getsState $ getActorBag aid cstore+  let req = ReqApply iid cstore+  if EM.notMember iid bag+    then execFailure aid req ApplyOutOfReach+    else do+      actorBlind <- radiusBlind+                    <$> sumOrganEqpServer Effect.EqpSlotAddSight aid+      item <- getsState $ getItemBody iid+      let blindScroll = jsymbol item == '?' && actorBlind+      if blindScroll+        then execFailure aid req ApplyBlind+        else applyItem aid iid cstore++-- * ReqTrigger++-- | Perform the effect specified for the tile in case it's triggered.+reqTrigger :: (MonadAtomic m, MonadServer m)+           => ActorId -> Maybe F.Feature -> m ()+reqTrigger aid mfeat = do+  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops+  sb <- getsState $ getActorBody aid+  let lid = blid sb+  lvl <- getLevel lid+  let tpos = bpos sb+      serverTile = lvl `at` tpos+      feats = case mfeat of+        Nothing -> TileKind.tfeature $ okind serverTile+        Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]+        Just _ -> []+      req = ReqTrigger mfeat+  go <- triggerEffect aid feats+  unless go $ execFailure aid req TriggerNothing++triggerEffect :: (MonadAtomic m, MonadServer m)+              => ActorId -> [F.Feature] -> m Bool+triggerEffect aid feats = do+  sb <- getsState $ getActorBody aid+  let tpos = bpos sb+      triggerFeat feat =+        case feat of+          F.Cause ef -> do+            -- No block against tile, hence unconditional.+            execSfxAtomic $ SfxTrigger aid tpos feat+            void $ effectsSem [ef] aid aid False+            return True+          _ -> return False+  goes <- mapM triggerFeat feats+  return $! or goes++-- * ReqGameRestart++-- TODO: implement a handshake and send hero names there,+-- so that they are available in the first game too,+-- not only in subsequent, restarted, games.+reqGameRestart :: (MonadAtomic m, MonadServer m)+               => ActorId -> Text -> Int -> [(Int, (Text, Text))] -> m ()+reqGameRestart aid stInfo d configHeroNames = do+  modifyServer $ \ser ->+    ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d+                                     , sdebugCli = (sdebugCli (sdebugNxt ser))+                                                     {sdifficultyCli = d}+                                     }}+  b <- getsState $ getActorBody aid+  let fid = bfid b+  oldSt <- getsState $ gquit . (EM.! fid) . sfactionD+  modifyServer $ \ser ->+    ser { squit = True  -- do this at once+        , sheroNames = EM.insert fid configHeroNames $ sheroNames ser }+  revealItems Nothing Nothing+  execUpdAtomic $ UpdQuitFaction fid (Just b) oldSt+                $ Just $ Status Restart (fromEnum $ blid b) stInfo++-- * ReqGameExit++reqGameExit :: (MonadAtomic m, MonadServer m) => ActorId -> Int -> m ()+reqGameExit aid d = do+  modifyServer $ \ser ->+    ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d+                                     , sdebugCli = (sdebugCli (sdebugNxt ser))+                                                     {sdifficultyCli = d}+                                     }}+  b <- getsState $ getActorBody aid+  let fid = bfid b+  oldSt <- getsState $ gquit . (EM.! fid) . sfactionD+  modifyServer $ \ser -> ser {sbkpSave = True}+  modifyServer $ \ser -> ser {squit = True}  -- do this at once+  execUpdAtomic $ UpdQuitFaction fid (Just b) oldSt+                $ Just $ Status Camping (fromEnum $ blid b) ""++-- * ReqGameSave++reqGameSave :: MonadServer m => m ()+reqGameSave = do+  modifyServer $ \ser -> ser {sbkpSave = True}+  modifyServer $ \ser -> ser {squit = True}  -- do this at once++-- * ReqAutomate++reqAutomate :: (MonadAtomic m, MonadServer m) => FactionId -> m ()+reqAutomate fid = execUpdAtomic $ UpdAutoFaction fid True
+ Game/LambdaHack/Server/ItemRev.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | Server types and operations for items that don't involve server state+-- nor our custom monads.+module Game.LambdaHack.Server.ItemRev+  ( ItemRev, buildItem, newItem+    -- * Item discovery types+  , DiscoRev, serverDiscos, ItemSeedDict+    -- * The @FlavourMap@ type+  , FlavourMap, emptyFlavourMap, dungeonFlavourMap+  ) where++import Control.Exception.Assert.Sugar+import Control.Monad+import Data.Binary+import qualified Data.EnumMap.Strict as EM+import qualified Data.HashMap.Strict as HM+import qualified Data.Ix as Ix+import Data.List+import qualified Data.Set as S+import Data.Text (Text)++import Game.LambdaHack.Common.Flavour+import Game.LambdaHack.Common.Frequency+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Content.ItemKind++-- | The reverse map to @Discovery@, needed for item creation.+type DiscoRev = EM.EnumMap (Kind.Id ItemKind) ItemKindIx++-- | The map of item ids to item seeds.+-- The full map is known by the server.+type ItemSeedDict = EM.EnumMap ItemId ItemSeed++serverDiscos :: Kind.Ops ItemKind -> Rnd (Discovery, DiscoRev)+serverDiscos Kind.Ops{obounds, ofoldrWithKey} = do+  let ixs = map toEnum $ take (Ix.rangeSize obounds) [0..]+      shuffle :: Eq a => [a] -> Rnd [a]+      shuffle [] = return []+      shuffle l = do+        x <- oneOf l+        fmap (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)+      f ik  _ (ikMap, _, []) =+        assert `failure` "too short ixs" `twith` (ik, ikMap)+      (discoS, discoRev, _) =+        ofoldrWithKey f (EM.empty, EM.empty, shuffled)+  return (discoS, discoRev)++-- | Build an item with the given stats.+buildItem :: FlavourMap -> DiscoRev -> Kind.Id ItemKind -> ItemKind -> LevelId+          -> Item+buildItem (FlavourMap flavour) discoRev ikChosen kind jlid =+  let jkindIx  = discoRev EM.! ikChosen+      jsymbol  = isymbol kind+      jname    = iname kind+      jflavour =+        case iflavour kind of+          [fl] -> fl+          _ -> flavour EM.! ikChosen+      jfeature = ifeature kind+      jweight = iweight kind+  in Item{..}++-- | Generate an item based on level.+newItem :: Kind.COps -> FlavourMap -> DiscoRev+        -> Freqs -> LevelId -> AbsDepth -> AbsDepth+        -> Rnd (Maybe (ItemKnown, ItemFull, ItemSeed, Int, Text))+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+        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)+      f itemGroup q p ik kind acc =+        let rarity = linearInterpolation (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+  if nullFreq freq then return Nothing+  else do+    ((itemKindId, itemKind), itemGroup) <- frequency freq+    itemN <- castDice ldepth totalDepth (icount itemKind)+    seed <- fmap toEnum random+    let itemBase = buildItem flavour discoRev itemKindId itemKind jlid+        itemK = max 1 itemN+        iae = seedToAspectsEffects seed itemKind ldepth totalDepth+        itemFull = ItemFull {itemBase, itemK, itemDisco = Just itemDisco}+        itemDisco = ItemDisco {itemKindId, itemKind, itemAE = Just iae}+    return $ Just ( (itemBase, iae)+                  , itemFull+                  , seed+                  , itemK+                  , itemGroup )++-- | Flavours assigned by the server to item kinds, in this particular game.+newtype FlavourMap = FlavourMap (EM.EnumMap (Kind.Id ItemKind) Flavour)+  deriving (Show, Binary)++emptyFlavourMap :: FlavourMap+emptyFlavourMap = FlavourMap EM.empty++-- | Assigns flavours to item kinds. Assures no flavor is repeated,+-- except for items with only one permitted flavour.+rollFlavourMap :: S.Set Flavour -> Kind.Id ItemKind -> ItemKind+               -> Rnd ( EM.EnumMap (Kind.Id ItemKind) Flavour+                      , EM.EnumMap Char (S.Set Flavour) )+               -> Rnd ( EM.EnumMap (Kind.Id ItemKind) Flavour+                      , EM.EnumMap Char (S.Set Flavour) )+rollFlavourMap fullFlavSet key ik rnd =+  let flavours = iflavour ik+  in if length flavours == 1+     then rnd+     else do+       (assocs, availableMap) <- rnd+       let available = EM.findWithDefault fullFlavSet (isymbol ik) availableMap+           proper = S.fromList flavours `S.intersection` available+       assert (not (S.null proper)+               `blame` "not enough flavours for items"+               `twith` (flavours, available, ik, availableMap)) $ do+         flavour <- oneOf (S.toList proper)+         let availableReduced = S.delete flavour available+         return ( EM.insert key flavour assocs+                , EM.insert (isymbol ik) availableReduced availableMap)++-- | Randomly chooses flavour for all item kinds for this game.+dungeonFlavourMap :: Kind.Ops ItemKind -> Rnd FlavourMap+dungeonFlavourMap Kind.Ops{ofoldrWithKey} =+  liftM (FlavourMap . fst) $+    ofoldrWithKey (rollFlavourMap (S.fromList stdFlav))+                  (return (EM.empty, EM.empty))++-- | Reverse item map, for item creation, to keep items and item identifiers+-- in bijection.+type ItemRev = HM.HashMap ItemKnown ItemId
+ Game/LambdaHack/Server/ItemServer.hs view
@@ -0,0 +1,134 @@+-- | Server operations for items.+module Game.LambdaHack.Server.ItemServer+  ( rollAndRegisterItem, registerItem, createItems, placeItemsInDungeon+  , fullAssocsServer, activeItemsServer, itemToFullServer, mapActorCStore_+  ) where++import Control.Monad+import qualified Data.EnumMap.Strict as EM+import qualified Data.HashMap.Strict as HM+import Data.Key (mapWithKeyM_)+import Data.Text (Text)++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Server.ItemRev+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++registerItem :: (MonadAtomic m, MonadServer m)+             => ItemKnown -> ItemSeed -> Int -> Container -> Bool -> m ItemId+registerItem itemKnown@(item, 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+      return iid+    Nothing -> do+      icounter <- getsServer sicounter+      modifyServer $ \ser ->+        ser { sicounter = succ icounter+            , sitemRev = HM.insert itemKnown icounter (sitemRev ser)+            , sitemSeedD = EM.insert icounter seed (sitemSeedD ser)+            , sdiscoAE = EM.insert icounter iae (sdiscoAE ser)}+      execUpdAtomic $ cmd icounter item k container+      return $! icounter++createItems :: (MonadAtomic m, MonadServer m)+            => Int -> Point -> LevelId -> m ()+createItems n pos lid = do+  Level{litemFreq} <- getLevel lid+  let container = CFloor lid pos+  replicateM_ n $ void $ rollAndRegisterItem lid litemFreq container True++rollAndRegisterItem :: (MonadAtomic m, MonadServer m)+                    => LevelId -> Freqs -> Container -> Bool+                    -> m (Maybe (ItemId, (ItemFull, Text)))+rollAndRegisterItem lid itemFreq container verbose = do+  cops <- getsState scops+  flavour <- getsServer sflavour+  discoRev <- getsServer sdiscoRev+  totalDepth <- getsState stotalDepth+  Level{ldepth} <- getLevel lid+  m4 <- rndToAction+        $ newItem cops flavour discoRev itemFreq lid ldepth totalDepth+  case m4 of+    Nothing -> return Nothing+    Just (itemKnown, itemFull, seed, k, itemGroup) -> do+      iid <- registerItem itemKnown seed k container verbose+      return $ Just (iid, (itemFull, itemGroup))++placeItemsInDungeon :: (MonadAtomic m, MonadServer m) => m ()+placeItemsInDungeon = do+  Kind.COps{cotile} <- getsState scops+  let initialItems lid (Level{ltile, litemNum, lxsize, lysize}) = do+        let factionDist = max lxsize lysize - 5+        replicateM (3 * litemNum `div` 2) $ do+          Level{lfloor} <- getLevel lid+          let dist p = minimum $ maxBound : map (chessDist p) (EM.keys lfloor)+          pos <- rndToAction $ findPosTry 100 ltile+                   (\_ t -> Tile.isWalkable cotile t+                            && (not $ Tile.hasFeature cotile F.NoItem t))+                   [ \p t -> Tile.hasFeature cotile F.OftenItem t+                             && dist p > factionDist `div` 5+                   , \p t -> Tile.hasFeature cotile F.OftenItem t+                             && dist p > factionDist `div` 7+                   , \p t -> Tile.hasFeature cotile F.OftenItem t+                             && dist p > factionDist `div` 9+                   , \p t -> Tile.hasFeature cotile F.OftenItem t+                             && dist p > factionDist `div` 12+                   , \p _ -> dist p > factionDist `div` 5+                   , \p t -> Tile.hasFeature cotile F.OftenItem t+                             || dist p > factionDist `div` 7+                   , \p t -> Tile.hasFeature cotile F.OftenItem t+                             || dist p > factionDist `div` 9+                   , \p t -> Tile.hasFeature cotile F.OftenItem t+                             || dist p > factionDist `div` 12+                   , \p _ -> dist p > 1+                   , \p _ -> EM.notMember p lfloor+                   ]+          createItems 1 pos lid+  dungeon <- getsState sdungeon+  mapWithKeyM_ initialItems dungeon++fullAssocsServer :: MonadServer m+                 => ActorId -> [CStore] -> m [(ItemId, ItemFull)]+fullAssocsServer aid cstores = do+  cops <- getsState scops+  disco <- getsServer sdisco+  discoAE <- getsServer sdiscoAE+  getsState $ fullAssocs cops disco discoAE aid cstores++activeItemsServer :: MonadServer m => ActorId -> m [ItemFull]+activeItemsServer aid = do+  activeAssocs <- fullAssocsServer aid [CEqp, COrgan]+  return $! map snd activeAssocs++itemToFullServer :: MonadServer m => m (ItemId -> Int -> ItemFull)+itemToFullServer = do+  cops <- getsState scops+  disco <- getsServer sdisco+  discoAE <- getsServer sdiscoAE+  s <- getState+  let itemToF iid = itemToFull cops disco discoAE iid (getItemBody iid s)+  return itemToF++-- | Mapping over actor's items from a give store.+mapActorCStore_ :: MonadServer m+                => CStore -> (ItemId -> Int -> m a) -> Actor ->  m ()+mapActorCStore_ cstore f b = do+  bag <- getsState $ getBodyActorBag b cstore+  mapM_ (uncurry f) $ EM.assocs bag
− Game/LambdaHack/Server/LoopAction.hs 
@@ -1,618 +0,0 @@--- | The main loop of the server, processing human and computer player--- moves turn by turn.-module Game.LambdaHack.Server.LoopAction (loopSer) where--import Control.Arrow ((&&&))-import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.List-import Data.Maybe-import qualified Data.Ord as Ord-import Data.Text (Text)--import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.AtomicCmd-import Game.LambdaHack.Common.ClientCmd-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.ServerCmd-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ActorKind-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Frontend-import Game.LambdaHack.Server.Action hiding (sendUpdateAI, sendUpdateUI)-import Game.LambdaHack.Server.EffectSem-import Game.LambdaHack.Server.Fov-import Game.LambdaHack.Server.ServerSem-import Game.LambdaHack.Server.StartAction-import Game.LambdaHack.Server.State-import Game.LambdaHack.Utils.Frequency---- | Start a game session. Loop, communicating with clients.-loopSer :: (MonadAtomic m, MonadConnServer m)-        => DebugModeSer-        -> (CmdSer -> m Bool)-        -> (FactionId -> ChanFrontend -> ChanServer CmdClientUI CmdSer-            -> IO ())-        -> (FactionId -> ChanServer CmdClientAI CmdTakeTimeSer-            -> IO ())-        -> Kind.COps-        -> m ()-loopSer sdebug cmdSerSem executorUI executorAI !cops = do-  -- Recover states and launch clients.-  restored <- tryRestore cops sdebug-  case restored of-    Just (sRaw, ser) | not $ snewGameSer sdebug -> do  -- run a restored game-      -- First, set the previous cops, to send consistent info to clients.-      let setPreviousCops = const cops-      execCmdAtomic $ ResumeServerA $ updateCOps setPreviousCops sRaw-      putServer ser-      sdebugNxt <- initDebug cops sdebug-      modifyServer $ \ser2 -> ser2 {sdebugNxt}-      applyDebug-      updateConn executorUI executorAI-      initPer-      pers <- getsServer sper-      broadcastCmdAtomic $ \fid -> ResumeA fid (pers EM.! fid)-      -- Second, set the current cops and reinit perception.-      let setCurrentCops = const (speedupCOps (sallClear sdebugNxt) cops)-      -- @sRaw@ is correct here, because none of the above changes State.-      execCmdAtomic $ ResumeServerA $ updateCOps setCurrentCops sRaw-    _ -> do  -- Starting a new game.-      -- Set up commandline debug mode-      let mrandom = case restored of-            Just (_, ser) -> Just $ srandom ser-            Nothing -> Nothing-      s <- gameReset cops sdebug mrandom-      sdebugNxt <- initDebug cops sdebug-      let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}-      modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs-                                 , sdebugSer = debugBarRngs }-      let speedup = speedupCOps (sallClear sdebugNxt)-      execCmdAtomic $ RestartServerA $ updateCOps speedup s-      updateConn executorUI executorAI-      initPer-      reinitGame-  when (sdumpInitRngs sdebug) $ dumpRngs-  resetSessionStart-  -- Start a clip (a part of a turn for which one or more frames-  -- will be generated). Do whatever has to be done-  -- every fixed number of time units, e.g., monster generation.-  -- Run the leader and other actors moves. Eventually advance the time-  -- and repeat.-  let loop = do-        let factionArena fact = do-              case gleader fact of-               -- Even spawners and horrors need an active arena-               -- for their leader, or they start clogging stairs.-               Just leader -> do-                  b <- getsState $ getActorBody leader-                  return $ Just $ blid b-               Nothing -> return Nothing-        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-        mapM_ (handleActors cmdSerSem) arenas-        quit <- getsServer squit-        if quit then do-          -- In case of game save+exit or restart, don't age levels (endClip)-          -- since possibly not all actors have moved yet.-          modifyServer $ \ser -> ser {squit = False}-          endOrLoop (updateConn executorUI executorAI) loop-        else do-          continue <- endClip arenas-          when continue loop-  loop--initDebug :: MonadActionRO m => Kind.COps -> DebugModeSer -> m DebugModeSer-initDebug Kind.COps{corule} sdebugSer = do-  let stdRuleset = Kind.stdRuleset corule-  return $!-    (\dbg -> dbg {sfovMode =-        sfovMode dbg `mplus` Just (rfovMode stdRuleset)}) .-    (\dbg -> dbg {ssavePrefixSer =-        ssavePrefixSer dbg `mplus` Just (rsavePrefix stdRuleset)})-    $ sdebugSer--endClip :: (MonadAtomic m, MonadServer m, MonadConnServer m)-        => [LevelId] -> m Bool-endClip arenas = do-  Kind.COps{corule} <- getsState scops-  let stdRuleset = Kind.stdRuleset corule-      saveBkpClips = rsaveBkpClips stdRuleset-      leadLevelClips = rleadLevelClips stdRuleset-  -- TODO: a couple messages each clip to many clients is too costly.-  -- Store these on a queue and sum times instead of sending,-  -- until a different command needs to be sent. Include HealActorA-  -- from regenerateLevelHP, but keep it before AgeGameA.-  -- TODO: this is also needed to keep savefiles small (undo info).-  mapM_ (\lid -> execCmdAtomic $ AgeLevelA lid timeClip) arenas-  execCmdAtomic $ AgeGameA timeClip-  -- Perform periodic dungeon maintenance.-  time <- getsState stime-  let clipN = time `timeFit` timeClip-      clipInTurn = let r = timeTurn `timeFit` timeClip-                   in assert (r > 2) r-      clipMod = clipN `mod` clipInTurn-  bkpSave <- getsServer sbkpSave-  when (bkpSave || clipN `mod` saveBkpClips == 0) $ do-    modifyServer $ \ser -> ser {sbkpSave = False}-    saveBkpAll False-  when (clipN `mod` leadLevelClips == 0) leadLevelFlip-  -- Regenerate HP and add monsters each turn, not each clip.-  -- Do this on only one of the arenas to prevent micromanagement,-  -- e.g., spreading leaders across levels to bump monster generation.-  if clipMod == 1 then do-    arena <- rndToAction $ oneOf arenas-    regenerateLevelHP arena-    generateMonster arena-    stopAfter <- getsServer $ sstopAfter . sdebugSer-    case stopAfter of-      Nothing -> return True-      Just stopA -> do-        exit <- elapsedSessionTimeGT stopA-        if exit then do-          tellAllClipPS-          saveAndExit-          return False  -- don't re-enter the game loop-        else return True-  else return True---- | Perform moves for individual actors, as long as there are actors--- with the next move time less than or equal to the current level time.--- Some very fast actors may move many times a clip and then--- we introduce subclips and produce many frames per clip to avoid--- jerky movement. But most often we push exactly one frame or frame delay.-handleActors :: (MonadAtomic m, MonadConnServer m)-             => (CmdSer -> m Bool)-             -> LevelId-             -> m ()-handleActors cmdSerSem lid = do-  time <- getsState $ getLocalTime lid  -- the end of this clip, inclusive-  Level{lprio} <- getLevel lid-  quit <- getsServer squit-  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 /= gleader (factionD EM.! bfid b)-      order = Ord.comparing $-        ((>= 0) . bhp . snd) &&& bfid . snd &&& isLeader &&& 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-            | otherwise = if atime > time-                          then Nothing  -- no actor is ready for another move-                          else Just $ minimumBy order ams-  case mnext of-    _ | quit -> return ()-    Nothing -> return ()-    Just (aid, b) | bhp b < 0 && bproj b -> do-      -- A projectile hits an actor. The carried item is destroyed.-      -- TODO: perhaps don't destroy if no effect (NoEffect),-      -- to help testing items. But OTOH, we want most items to have-      -- some effect, even silly, for flavour. Anyway, if the silly-      -- effect identifies an item, the hit is not wasted, so this makes sense.-      dieSer aid b True-      -- The attack animation for the projectile hit subsumes @DisplayPushD@,-      -- so not sending an extra @DisplayPushD@ here.-      handleActors cmdSerSem lid-    Just (aid, b) | maybe False null (btrajectory b) -> do-      assert (bproj b) skip-      execSfxAtomic $ DisplayPushD (bfid b)  -- show last position before drop-      -- A projectile drops to the ground due to obstacles or range.-      dieSer aid b False-      handleActors cmdSerSem lid-    Just (aid, b) | bhp b <= 0 && not (bproj b) -> do-      -- An actor dies. Items drop to the ground-      -- and possibly a new leader is elected.-      dieSer aid b False-      -- The death animation subsumes @DisplayPushD@, so not sending it here.-      handleActors cmdSerSem lid-    Just (aid, body) -> do-      let side = bfid body-          fact = factionD EM.! side-          mleader = gleader fact-          aidIsLeader = mleader == Just aid-          queryUI | aidIsLeader = not $ playerAiLeader $ gplayer fact-                  | otherwise = not $ playerAiOther $ gplayer fact-          switchLeader cmdS = do-            -- TODO: check that the command is legal first, report and reject,-            -- but do not crash (currently server asserts things and crashes)-            let aidNew = aidCmdSer cmdS-            bPre <- getsState $ getActorBody aidNew-            let leadAtoms =-                  if aidNew /= aid  -- switched, so aid must be leader-                  then -- Only a leader can change his faction's leader-                       -- before the action is performed (e.g., via AI-                       -- switching leaders). Then, the action can change-                       -- the leader again (e.g., via killing the old leader).-                       assert (aidIsLeader-                               && not (bproj bPre)-                               && not (isSpawnFact fact)-                               `blame` (aid, body, aidNew, bPre, cmdS, fact))-                         [LeadFactionA side mleader (Just aidNew)]-                  else []-            mapM_ execCmdAtomic leadAtoms-            assert (bfid bPre == side-                    `blame` "client tries to move other faction actors"-                    `twith` (bPre, side)) skip-            return (aidNew, bPre)-          setBWait (CmdTakeTimeSer WaitSer{}) aidNew bPre = do-            let fromWait = bwait bPre-            unless fromWait $ execCmdAtomic $ WaitActorA aidNew fromWait True-          setBWait _ aidNew bPre = do-            let fromWait = bwait bPre-            when fromWait $ execCmdAtomic $ WaitActorA aidNew fromWait False-          extraFrames bPre = do-            -- Generate extra frames if the actor has already moved during-            -- this clip, so his multiple moves would be collapsed-            -- in one frame.-            -- If the actor changes his speed this very turn,-            -- the test can fail, but it's a minor UI issue, so let it be.-            let previousClipEnd = timeAdd time $ timeNegate timeClip-                lastSingleMove = timeAddFromSpeed bPre previousClipEnd-            when (btime bPre > lastSingleMove) $-              broadcastSfxAtomic DisplayPushD-      if bproj body then do  -- TODO: perhaps check Track, not bproj-        execSfxAtomic $ DisplayPushD side-        let cmdS = CmdTakeTimeSer $ SetTrajectorySer aid-        timed <- cmdSerSem cmdS-        assert timed skip-        b <- getsState $ getActorBody aid-        -- Colliding with a wall or actor doesn't take time, because-        -- the projectile does not move (the move is blocked).-        -- Not advancing time forces dead projectiles to be destroyed ASAP.-        -- Otherwise it would be displayed in the same place twice.-        -- If ever needed this can be implemented properly by moving-        -- SetTrajectorySer out of CmdTakeTimeSer.-        unless (bhp b < 0 || maybe False null (btrajectory b)) $ do-          advanceTime aid-          extraFrames b-      else if queryUI then do-        -- The client always displays a frame in this case.-        cmdS <- sendQueryUI side aid-        (aidNew, bPre) <- switchLeader cmdS-        timed <--          if bhp bPre <= 0 && not (bproj bPre) then do-            execSfxAtomic-              $ MsgFidD side "You strain, fumble and faint from the exertion."-            return False-          else cmdSerSem cmdS-        setBWait cmdS aidNew bPre-        -- Advance time once, after the leader switched perhaps many times.-        -- TODO: this is correct only when all heroes have the same-        -- speed and can't switch leaders by, e.g., aiming a wand-        -- of domination. We need to generalize by displaying-        -- "(next move in .3s [RET]" when switching leaders.-        -- RET waits .3s and gives back control,-        -- Any other key does the .3s wait and the action from the key-        -- at once.-        when timed $ advanceTime aidNew-        extraFrames bPre-      else do-        -- Order the UI client (if any) corresponding to the AI client-        -- to display a new frame so that player does not see moves-        -- of all his AI party members cumulated in a single frame,-        -- but one by one.-        execSfxAtomic $ DisplayPushD side-        -- Clear messages in the UI client (if any), if the actor-        -- is a leader (which happens when a UI client is fully-        -- computer-controlled). We could record history more often,-        -- to avoid long reports, but we'd have to add -more- prompts.-        let mainUIactor = playerUI (gplayer fact) && aidIsLeader-        when mainUIactor $ execSfxAtomic $ RecordHistoryD side-        cmdTimed <- sendQueryAI side aid-        let cmdS = CmdTakeTimeSer cmdTimed-        (aidNew, bPre) <- switchLeader cmdS-        assert (not (bhp bPre <= 0 && not (bproj bPre))-                `blame` "AI switches to an incapacitated actor"-                `twith` (cmdS, bPre, side)) skip-        timed <- cmdSerSem cmdS-        assert timed skip-        setBWait cmdS aidNew bPre-        -- AI always takes time and so doesn't loop.-        advanceTime aidNew-        extraFrames bPre-      handleActors cmdSerSem lid--dieSer :: (MonadAtomic m, MonadServer m) => ActorId -> Actor -> Bool -> m ()-dieSer aid b hit = do-  -- TODO: clients don't see the death of their last standing actor;-  --       modify Draw.hs and Client.hs to handle that-  if bproj b then do-    dropAllItems aid b hit-    b2 <- getsState $ getActorBody aid-    execCmdAtomic $ DestroyActorA aid b2 []-  else do-    electLeader (bfid b) (blid b) aid-    deduceKilled b-    dropAllItems aid b False-    b2 <- getsState $ getActorBody aid-    execCmdAtomic $ DestroyActorA aid b2 []---- | Drop all actor's items. If the actor hits another actor and this--- collision results in all item being dropped, all items are destroyed.--- If the actor does not hit, but dies, only fragile items are destroyed--- and only if the actor was a projectile (and so died by dropping--- to the ground due to exceeded range or bumping off an obstacle).-dropAllItems :: (MonadAtomic m, MonadServer m)-             => ActorId -> Actor -> Bool -> m ()-dropAllItems aid b hit = do-  Kind.COps{coitem} <- getsState scops-  discoS <- getsServer sdisco-  let isDestroyed item = hit || bproj b && isFragile coitem discoS item-      f iid k = do-        let container = actorContainer aid (binv b) iid-        item <- getsState $ getItemBody iid-        if isDestroyed item then-          case isExplosive coitem discoS item of-            Nothing -> execCmdAtomic $ DestroyItemA iid item k container-            Just cgroup -> do-              let ik = fromJust $ jkind discoS item-              execCmdAtomic $ DiscoverA (blid b) (bpos b) iid ik-              execCmdAtomic $ DestroyItemA iid item k container-              explodeItem aid b container cgroup-        else-          execCmdAtomic $ MoveItemA iid k container (CFloor (blid b) (bpos b))-  mapActorItems_ f b--explodeItem :: (MonadAtomic m, MonadServer m)-            => ActorId -> Actor -> Container -> Text -> m ()-explodeItem aid b container cgroup = do-  Kind.COps{coitem} <- getsState scops-  flavour <- getsServer sflavour-  discoRev <- getsServer sdiscoRev-  Level{ldepth} <- getLevel $ blid b-  depth <- getsState sdepth-  let itemFreq = toFreq "shrapnel group" [(1, cgroup)]-  (item, n1, _) <- rndToAction-                   $ newItem coitem flavour discoRev itemFreq ldepth depth-  iid <- registerItem item n1 container False-  let Point x y = bpos b-      projectN n = replicateM_ n $ do-        tpxy <- rndToAction $ do-          border <- randomR (1, 4)-          -- We pick a point at the border, not inside, to have a uniform-          -- distribution for the points the line goes through at each distance-          -- from the source. Otherwise, e.g., the points on cardinal-          -- and diagonal lines from the source would be more common.-          case border :: Int of-            1 -> fmap (Point (x - 10)) $ randomR (y - 10, y + 10)-            2 -> fmap (Point (x + 10)) $ randomR (y - 10, y + 10)-            3 -> fmap (flip Point (y - 10)) $ randomR (x - 10, x + 10)-            4 -> fmap (flip Point (y + 10)) $ randomR (x - 10, x + 10)-            _ -> assert `failure` border-        let eps = px tpxy + py tpxy-        mfail <- projectFail aid tpxy eps iid container True-        case mfail of-          Nothing -> return ()-          Just ProjectBlockTerrain -> return ()-          Just failMsg -> execFailure aid failMsg-  projectN n1-  bag2 <- getsState $ bbag . getActorBody aid-  let mn2 = EM.lookup iid bag2-  maybe skip projectN mn2  -- assume all shrapnels bounce off obstacles once-  bag3 <- getsState $ bbag . getActorBody aid-  let mn3 = EM.lookup iid bag3-  maybe skip (\k -> execCmdAtomic $ LoseItemA iid item k container) mn3---- | Advance the move time for the given actor.-advanceTime :: MonadAtomic m => ActorId -> m ()-advanceTime aid = do-  b <- getsState $ getActorBody aid-  let t = ticksPerMeter $ bspeed b-  execCmdAtomic $ AgeActorA aid t---- | Generate a monster, possibly.-generateMonster :: (MonadAtomic m, MonadServer m) => LevelId -> m ()-generateMonster lid = do-  cops <- getsState scops-  pers <- getsServer sper-  lvl@Level{ldepth} <- getLevel lid-  s <- getState-  let f fid = isSpawnFaction fid s-      spawns = actorNotProjList f lid s-  depth <- getsState sdepth-  rc <- rndToAction $ monsterGenChance ldepth depth (length spawns)-  factionD <- getsState sfactionD-  when rc $ do-    time <- getsState $ getLocalTime lid-    let freq = toFreq "spawn"-               $ map (\(fid, fact) -> (playerSpawn $ gplayer fact, fid))-               $ EM.assocs factionD-    mfid <- if nullFreq freq then-              return Nothing-            else fmap Just $ rndToAction $ frequency freq-    case mfid of-      Nothing -> return ()  -- no faction spawns-      Just fid -> do-        let allPers = ES.unions $ map (totalVisible . (EM.! lid))-                      $ EM.elems $ EM.delete fid pers  -- expensive :(-        pos <- rndToAction $ rollSpawnPos cops allPers lid lvl fid s-        spawnMonsters [pos] lid time fid--rollSpawnPos :: Kind.COps -> ES.EnumSet Point-             -> LevelId -> Level -> FactionId -> State-             -> Rnd Point-rollSpawnPos Kind.COps{cotile} visible-             lid Level{ltile, lxsize, lysize} fid s = do-  let factionDist = max lxsize lysize - 5-      inhabitants = actorNotProjList (/= fid) lid s-      as = actorList (const True) lid s-      isLit = Tile.isLit cotile-      distantAtLeast d p _ =-        all (\b -> chessDist (bpos b) p > d) inhabitants-  findPosTry 40 ltile-    ( \p t -> Tile.isWalkable cotile t-              && unoccupied as p)-    [ \_ t -> not (isLit t)  -- no such tiles on some maps-    , distantAtLeast factionDist-    , distantAtLeast $ factionDist `div` 2-    , \p _ -> not $ p `ES.member` visible-    , distantAtLeast $ factionDist `div` 3-    , \_ t -> Tile.hasFeature cotile F.CanActor t  -- in reachable area-    , distantAtLeast $ factionDist `div` 4-    , distantAtLeast 3  -- otherwise a fast actor can walk and hit in one turn-    ]---- TODO: generalize to any list of items (or effects) applied to all actors--- every turn. Specify the list per level in config.--- TODO: use itemEffect or at least effectSem to get from Regeneration--- to HealActorA. Also, Applying an item with Regeneration should do the same--- thing, but immediately (and destroy the item).--- | Possibly regenerate HP for all actors on the current level.------ We really want leader picking to be a purely UI distinction,--- so all actors need to regenerate, not just the leaders.--- Actors on frozen levels don't regenerate. This prevents cheating--- via sending an actor to a safe level and letting him regenerate there.-regenerateLevelHP :: MonadAtomic m => LevelId -> m ()-regenerateLevelHP lid = do-  Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops-  time <- getsState $ getLocalTime lid-  s <- getState-  let approve (a, m) =-        let ak = okind $ bkind m-            itemAssocs = getActorItem a s-            regen = max 1 $-                      aregen ak `div`-                      case strongestRegen itemAssocs of-                        Just (k, _)  -> k + 1-                        Nothing -> 1-            bhpMax = maxDice (ahp ak)-            deltaHP = min 1 (bhpMax - bhp m)-        in if (time `timeFit` timeTurn) `mod` regen /= 0-              || deltaHP <= 0-              || bhp m <= 0-           then Nothing-           else Just a-  toRegen <- getsState $ mapMaybe approve . actorNotProjAssocs (const True) lid-  mapM_ (\aid -> execCmdAtomic $ HealActorA aid 1) toRegen--leadLevelFlip :: (MonadAtomic m, MonadServer m) => m ()-leadLevelFlip = do-  Kind.COps{cotile} <- getsState scops-  let canFlip fact = playerAiLeader (gplayer fact)-                     || isSpawnFact fact-      flipFaction fact | not $ canFlip fact = return ()-      flipFaction fact = do-        case gleader fact of-          Nothing -> return ()-          Just leader -> do-            body <- getsState $ getActorBody leader-            lvl2 <- getLevel $ blid body-            let leaderStuck = waitedLastTurn body-                t = lvl2 `at` bpos body-            -- Keep the leader: he is on stairs and not stuck-            -- and we don't want to clog stairs or get pushed to another level.-            unless (not leaderStuck && Tile.isStair cotile t) $ do-              actorD <- getsState sactorD-              let ourLvl (lid, lvl) =-                    ( lid-                    , EM.size (lfloor lvl)-                    , actorNotProjAssocsLvl (== bfid body) lvl actorD )-              ours <- getsState $ map ourLvl . EM.assocs . sdungeon-              -- Non-humans, being born in the dungeon, have a rough idea of-              -- the number of items left on the level and will focus-              -- on levels they started exploring and that have few items-              -- left. This is to to explore them completely, leave them-              -- once and for all and concentrate forces on another level.-              -- In addition, sole stranded actors tend to become leaders-              -- so that they can join the main force ASAP.-              let freqList = [ (k, (lid, a))-                             | (lid, itemN, (a, b) : rest) <- ours-                             , bhp b > 0  -- drama levels skipped-                             , not leaderStuck || lid /= blid body-                             , let len = 1 + (min 10 $ length rest)-                                   k = 1000000 `div` (3 * itemN + len) ]-              unless (null freqList) $ do-                (lid, a) <- rndToAction $ frequency-                                        $ toFreq "leadLevel" freqList-                unless (lid == blid body) $-                  execCmdAtomic-                  $ LeadFactionA (bfid body) (Just leader) (Just a)-  factionD <- getsState sfactionD-  mapM_ flipFaction $ EM.elems factionD---- | Continue or exit or restart the game.-endOrLoop :: (MonadAtomic m, MonadConnServer m) => m () -> m () -> m ()-endOrLoop updConn loopServer = do-  factionD <- getsState sfactionD-  let inGame fact = case gquit fact of-        Nothing -> True-        Just Status{stOutcome=Camping} -> True-        _ -> False-      gameOver = not $ any inGame $ EM.elems factionD-  let getQuitter fact = case gquit fact of-        Just Status{stOutcome=Restart, stInfo} -> Just stInfo-        _ -> Nothing-      quitters = mapMaybe getQuitter $ EM.elems factionD-  let isCamper fact = case gquit fact of-        Just Status{stOutcome=Camping} -> True-        _ -> False-      campers = filter (isCamper . snd) $ EM.assocs factionD-  case (quitters, campers) of-    (sgameMode : _, _) -> do-      modifyServer $ \ser -> ser {sdebugNxt = (sdebugNxt ser) {sgameMode}}-      restartGame updConn loopServer-    _ | gameOver -> restartGame updConn loopServer-    ([], []) -> loopServer  -- continue current game-    ([], _ : _) -> do-      -- Wipe out the quit flag for the savegame files.-      mapM_ (\(fid, fact) ->-              execCmdAtomic-              $ QuitFactionA fid Nothing (gquit fact) Nothing) campers-      saveAndExit-      -- Don't call @loopServer@, that is, quit the game loop.-      -- debugPrint "Server loop finished"--saveAndExit :: (MonadAtomic m, MonadConnServer m) => m ()-saveAndExit = do-  cops <- getsState scops-  -- Save client and server data.-  saveBkpAll True-  -- debugPrint "Server saves game before exit"-  -- Kill all clients, including those that did not take part-  -- in the current game.-  -- Clients exit not now, but after they print all ending screens.-  -- debugPrint "Server kills clients"-  killAllClients-  -- Verify that the saved perception is equal to future reconstructed.-  persSaved <- getsServer sper-  fovMode <- getsServer $ sfovMode . sdebugSer-  pers <- getsState $ dungeonPerception cops-                                        (fromMaybe (Digital 12) fovMode)-  assert (persSaved == pers `blame` "wrong saved perception"-                            `twith` (persSaved, pers)) skip--restartGame :: (MonadAtomic m, MonadConnServer m)-            => m () -> m () -> m ()-restartGame updConn loopServer = do-  tellGameClipPS-  cops <- getsState scops-  sdebugNxt <- getsServer sdebugNxt-  srandom <- getsServer srandom-  s <- gameReset cops sdebugNxt $ Just srandom-  let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}-  modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs-                             , sdebugSer = debugBarRngs }-  execCmdAtomic $ RestartServerA s-  updConn-  initPer-  reinitGame-  loopServer
+ Game/LambdaHack/Server/LoopServer.hs view
@@ -0,0 +1,388 @@+{-# LANGUAGE GADTs #-}+-- | The main loop of the server, processing human and computer player+-- moves turn by turn.+module Game.LambdaHack.Server.LoopServer (loopSer) where++import Control.Arrow ((&&&))+import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES+import Data.Key (mapWithKeyM_)+import Data.List+import Data.Maybe+import qualified Data.Ord as Ord++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Color as Color+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+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.Random+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.Response+import Game.LambdaHack.Common.State+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Server.EndServer+import Game.LambdaHack.Server.Fov+import Game.LambdaHack.Server.HandleEffectServer+import Game.LambdaHack.Server.HandleRequestServer+import Game.LambdaHack.Server.ItemServer+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.PeriodicServer+import Game.LambdaHack.Server.ProtocolServer+import Game.LambdaHack.Server.StartServer+import Game.LambdaHack.Server.State++-- | Start a game session. Loop, communicating with clients.+loopSer :: (MonadAtomic m, MonadServerReadRequest m)+        => DebugModeSer+        -> (FactionId -> ChanServer ResponseUI RequestUI -> IO ())+        -> (FactionId -> ChanServer ResponseAI RequestAI -> IO ())+        -> Kind.COps+        -> m ()+loopSer sdebug executorUI executorAI !cops = do+  -- Recover states and launch clients.+  let updConn = updateConn executorUI executorAI+  restored <- tryRestore cops sdebug+  case restored of+    Just (sRaw, ser) | not $ snewGameSer sdebug -> do  -- run a restored game+      -- First, set the previous cops, to send consistent info to clients.+      let setPreviousCops = const cops+      execUpdAtomic $ UpdResumeServer $ updateCOps setPreviousCops sRaw+      putServer ser+      sdebugNxt <- initDebug cops sdebug+      modifyServer $ \ser2 -> ser2 {sdebugNxt}+      applyDebug+      updConn+      initPer+      pers <- getsServer sper+      broadcastUpdAtomic $ \fid -> UpdResume fid (pers EM.! fid)+      -- Second, set the current cops and reinit perception.+      let setCurrentCops = const (speedupCOps (sallClear sdebugNxt) cops)+      -- @sRaw@ is correct here, because none of the above changes State.+      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+    _ -> 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+      sdebugNxt <- initDebug cops sdebug+      let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}+      modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs+                                 , sdebugSer = debugBarRngs }+      let speedup = speedupCOps (sallClear sdebugNxt)+      execUpdAtomic $ UpdRestartServer $ updateCOps speedup s+      updConn+      initPer+      reinitGame+      saveBkpAll False+  resetSessionStart+  -- Start a clip (a part of a turn for which one or more frames+  -- will be generated). Do whatever has to be done+  -- every fixed number of time units, e.g., monster generation.+  -- Run the leader and other actors moves. Eventually advance the time+  -- and repeat.+  let loop = do+        let factionArena fact = do+              case gleader fact of+               -- Even spawners and horrors need an active arena+               -- for their leader, or they start clogging stairs.+               Just leader -> do+                  b <- getsState $ getActorBody leader+                  return $ Just $ blid b+               Nothing -> return Nothing+        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+        mapM_ handleActors arenas+        quit <- getsServer squit+        if quit then do+          -- In case of game save+exit or restart, don't age levels (endClip)+          -- since possibly not all actors have moved yet.+          modifyServer $ \ser -> ser {squit = False}+          endOrLoop loop (restartGame updConn loop) gameExit (saveBkpAll True)+        else do+          continue <- endClip arenas+          when continue loop+  loop++endClip :: (MonadAtomic m, MonadServer m, MonadServerReadRequest m)+        => [LevelId] -> m Bool+endClip arenas = do+  Kind.COps{corule} <- getsState scops+  let stdRuleset = Kind.stdRuleset corule+      saveBkpClips = rsaveBkpClips stdRuleset+      leadLevelClips = rleadLevelClips stdRuleset+      ageProcessed lid processed =+        EM.insertWith absoluteTimeAdd lid timeClip processed+      ageServer lid ser = ser {sprocessed = ageProcessed lid $ sprocessed ser}+  mapM_ (modifyServer . ageServer) arenas+  execUpdAtomic $ UpdAgeGame (Delta timeClip) arenas+  -- Perform periodic dungeon maintenance.+  time <- getsState stime+  let clipN = time `timeFit` timeClip+      clipInTurn = let r = timeTurn `timeFit` timeClip+                   in assert (r > 2) r+      clipMod = clipN `mod` clipInTurn+  when (clipN `mod` saveBkpClips == 0) $ do+    modifyServer $ \ser -> ser {sbkpSave = False}+    saveBkpAll False+  when (clipN `mod` leadLevelClips == 0) leadLevelFlip+  -- 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.+  if clipMod == 1 then do+    arena <- rndToAction $ oneOf arenas+    activatePeriodicLevel arena+    spawnMonster arena+    stopAfter <- getsServer $ sstopAfter . sdebugSer+    case stopAfter of+      Nothing -> return True+      Just stopA -> do+        exit <- elapsedSessionTimeGT stopA+        if exit then do+          tellAllClipPS+          gameExit+          return False  -- don't re-enter the game loop+        else return True+  else return True++-- | Trigger periodic items for all actors on the given level.+-- This is done each game turn, not player turn, not to overpower+-- fast actors (assuming the effects are positive).+activatePeriodicLevel :: (MonadAtomic m, MonadServer m) => LevelId -> m ()+activatePeriodicLevel lid = do+  time <- getsState $ getLocalTime lid+  let turnN = time `timeFit` timeTurn+      activatePeriodicItem aid (iid, itemFull) = do+        case strengthFromEqpSlot Effect.EqpSlotPeriodic itemFull of+          Nothing -> return ()+          Just n -> when (turnN `mod` (100 `div` n) == 0) $+                      void $ itemEffect aid aid iid itemFull False True+            -- periodic activation doesn't destroy items, even non-Durable+      activatePeriodicActor aid = do+        allItems <- fullAssocsServer aid [COrgan, CEqp]+        mapM_ (activatePeriodicItem aid) allItems+  allActors <- getsState $ actorRegularAssocs (const True) lid+  mapM_ (\(aid, _) -> activatePeriodicActor 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.+handleActors :: (MonadAtomic m, MonadServerReadRequest m)+             => LevelId -> m ()+handleActors lid = do+  -- The end of this clip, inclusive. This is used exclusively+  -- to decide which actors to process this time. Transparent to clients.+  timeCutOff <- getsServer $ EM.findWithDefault timeClip lid . sprocessed+  Level{lprio} <- getLevel lid+  quit <- getsServer squit+  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 /= gleader (factionD EM.! bfid b)+      order = Ord.comparing $+        ((>= 0) . bhp . snd) &&& bfid . snd &&& isLeader &&& 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+            | otherwise = if atime > timeCutOff+                          then Nothing  -- no actor is ready for another move+                          else Just $ minimumBy order ams+      startActor aid = execSfxAtomic $ SfxActorStart aid+  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+      startActor aid+      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.+      -- TODO: perhaps don't destroy if no effect (NoEffect),+      -- to help testing items. But OTOH, we want most items to have+      -- some effect, even silly, for flavour. Anyway, if the silly+      -- effect identifies an item, the hit is not wasted, so this makes sense.+      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+      -- and possibly a new leader is elected.+      startActor aid+      dieSer aid b False+      handleActors lid+    Just (aid, body) -> do+      startActor aid+      let side = bfid body+          fact = factionD EM.! side+          mleader = gleader fact+          aidIsLeader = mleader == Just aid+      queryUI <-+        if playerUI (gplayer fact)+           && (aidIsLeader || not (playerLeader (gplayer fact))) then do+          let underAI = playerAI $ gplayer fact+          if underAI then do+            -- If UI client for the faction completely under AI control,+            -- ping often to sync frames and to catch ESC,+            -- which switches off Ai control.+            sendPingUI side+            fact2 <- getsState $ (EM.! side) . sfactionD+            let underAI2 = playerAI $ gplayer fact2+            return $! not underAI2+          else return True+        else return False+      let setBWait hasWait aidNew = do+            bPre <- getsState $ getActorBody aidNew+            when (hasWait /= bwait bPre) $+              execUpdAtomic $ UpdWaitActor aidNew hasWait+      if isJust $ btrajectory body then do+        timed <- setTrajectory aid+        when timed $ advanceTime aid+      else if queryUI then do+        cmdS <- sendQueryUI side aid+        -- TODO: check that the command is legal first, report and reject,+        -- but do not crash (currently server asserts things and crashes)+        aidNew <- handleRequestUI side cmdS+        let hasWait (ReqUITimed ReqWait{}) = True+            hasWait (ReqUILeader _ cmd) = hasWait cmd+            hasWait _ = False+        maybe skip (setBWait (hasWait cmdS)) aidNew+        -- Advance time once, after the leader switched perhaps many times.+        -- TODO: this is correct only when all heroes have the same+        -- speed and can't switch leaders by, e.g., aiming a wand+        -- of domination. We need to generalize by displaying+        -- "(next move in .3s [RET]" when switching leaders.+        -- RET waits .3s and gives back control,+        -- Any other key does the .3s wait and the action from the key+        -- at once.+        maybe skip advanceTime 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+        -- computer-controlled) or if faction is leaderless.+        -- We could record history more often, to avoid long reports,+        -- but we'd have to add -more- prompts.+        let mainUIactor = playerUI (gplayer fact)+                          && (aidIsLeader || not (playerLeader (gplayer fact)))+        when mainUIactor $ execUpdAtomic $ UpdRecordHistory side+        cmdS <- sendQueryAI side aid+        aidNew <- handleRequestAI side aid cmdS+        let hasWait (ReqAITimed ReqWait{}) = True+            hasWait (ReqAILeader _ cmd) = hasWait cmd+            hasWait _ = False+        setBWait (hasWait cmdS) aidNew+        -- AI always takes time and so doesn't loop.+        advanceTime aidNew+      handleActors lid++gameExit :: (MonadAtomic m, MonadServerReadRequest m) => m ()+gameExit = do+  -- Kill all clients, including those that did not take part+  -- in the current game.+  -- Clients exit not now, but after they print all ending screens.+  -- debugPrint "Server kills clients"+  killAllClients+  -- Verify that the saved perception is equal to future reconstructed.+  persAccumulated <- getsServer sper+  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++restartGame :: (MonadAtomic m, MonadServerReadRequest m)+            => m () -> m () -> m ()+restartGame updConn loop = do+  tellGameClipPS+  cops <- getsState scops+  sdebugNxt <- getsServer sdebugNxt+  srandom <- getsServer srandom+  s <- gameReset cops sdebugNxt $ Just srandom+  let debugBarRngs = sdebugNxt {sdungeonRng = Nothing, smainRng = Nothing}+  modifyServer $ \ser -> ser { sdebugNxt = debugBarRngs+                             , sdebugSer = debugBarRngs }+  execUpdAtomic $ UpdRestartServer s+  updConn+  initPer+  reinitGame+  saveBkpAll False+  loop++-- TODO: This can be improved by adding a timeout+-- and by asking clients to prepare+-- a save (in this way checking they have permissions, enough space, etc.)+-- and when all report back, asking them to commit the save.+-- | Save game on server and all clients. Clients are pinged first,+-- which greatly reduced the chance of saves being out of sync.+saveBkpAll :: (MonadAtomic m, MonadServerReadRequest m) => Bool -> m ()+saveBkpAll unconditional = do+  bench <- getsServer $ sbenchmark . sdebugSer+  when (unconditional || not bench) $ do+    factionD <- getsState sfactionD+    let ping fid _ = do+          sendPingAI fid+          when (playerUI $ gplayer $ factionD EM.! fid) $ sendPingUI fid+    mapWithKeyM_ ping factionD+    execUpdAtomic UpdSaveBkp+    saveServer++-- TODO: move somewhere?+-- | Manage trajectory of a projectile.+--+-- Colliding with a wall or actor doesn't take time, because+-- the projectile does not move (the move is blocked).+-- Not advancing time forces dead projectiles to be destroyed ASAP.+-- Otherwise, 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 aid = do+  cops <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  let clearTrajectory speed = 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+        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+    Just ([], _) -> do  -- non-projectile actor stops flying+      assert (not $ bproj b) skip+      execUpdAtomic $ UpdTrajectory aid (btrajectory b) Nothing+      return False+    _ -> assert `failure` "Nothing trajectory" `twith` (aid, b)
+ Game/LambdaHack/Server/MonadServer.hs view
@@ -0,0 +1,244 @@+-- | Game action monads and basic building blocks for human and computer+-- player actions. Has no access to the the main action type.+-- Does not export the @liftIO@ operation nor a few other implementation+-- details.+module Game.LambdaHack.Server.MonadServer+  ( -- * The server monad+    MonadServer( getServer, getsServer, modifyServer, putServer+               , saveChanServer  -- exposed only to be implemented, not used+               , liftIO  -- exposed only to be implemented, not used+               )+    -- * Assorted primitives+  , debugPrint, saveServer, saveName, dumpRngs+  , restoreScore, registerScore+  , resetSessionStart, resetGameStart, elapsedSessionTimeGT+  , tellAllClipPS, tellGameClipPS+  , tryRestore, speedupCOps, rndToAction, getSetGen+  ) where++import qualified Control.Exception as Ex hiding (handle)+import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Control.Monad.State as St+import qualified Data.EnumMap.Strict as EM+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as T+import System.Directory+import System.FilePath+import System.IO+import qualified System.Random as R+import System.Time++import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.File+import qualified Game.LambdaHack.Common.HighScore as HighScore+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Save+import qualified Game.LambdaHack.Common.Save as Save+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Server.State++class MonadStateRead m => MonadServer m where+  getServer      :: m StateServer+  getsServer     :: (StateServer -> a) -> m a+  modifyServer   :: (StateServer -> StateServer) -> m ()+  putServer      :: StateServer -> m ()+  -- We do not provide a MonadIO instance, so that outside of Action/+  -- nobody can subvert the action monads by invoking arbitrary IO.+  liftIO         :: IO a -> m a+  saveChanServer :: m (Save.ChanSave (State, StateServer))++debugPrint :: MonadServer m => Text -> m ()+debugPrint t = do+  debug <- getsServer $ sdbgMsgSer . sdebugSer+  when debug $ liftIO $ do+    T.hPutStrLn stderr t+    hFlush stderr++saveServer :: MonadServer m => m ()+saveServer = do+  s <- getState+  ser <- getServer+  toSave <- saveChanServer+  liftIO $ Save.saveToChan toSave (s, ser)++saveName :: String+saveName = serverSaveName++-- | Dumps RNG states from the start of the game to stderr.+dumpRngs :: MonadServer m => m ()+dumpRngs = do+  rngs <- getsServer srngs+  liftIO $ do+    T.hPutStrLn stderr $ tshow rngs+    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+restoreScore Kind.COps{corule} = do+  let stdRuleset = Kind.stdRuleset corule+      scoresFile = rscoresFile stdRuleset+  dataDir <- liftIO appDataDir+  let path = dataDir </> scoresFile+  configExists <- liftIO $ doesFileExist path+  mscore <- liftIO $ do+    res <- Ex.try $+      if configExists then do+        s <- strictDecodeEOF path+        return $ Just s+      else return Nothing+    let handler :: Ex.SomeException -> IO (Maybe a)+        handler e = do+          let msg = "High score restore failed. The error message is:"+                    <+> (T.unwords . T.lines) (tshow e)+          delayPrint $ msg+          return Nothing+    either handler return res+  maybe (return HighScore.empty) return mscore++-- | Generate a new score, register it and save.+registerScore :: MonadServer m => Status -> Maybe Actor -> FactionId -> m ()+registerScore status mbody fid = do+  cops@Kind.COps{corule} <- getsState scops+  assert (maybe True ((fid ==) . bfid) mbody) skip+  fact <- getsState $ (EM.! fid) . sfactionD+  total <- case mbody of+    Just body -> getsState $ snd . calculateTotal body+    Nothing -> case gleader fact of+      Nothing -> return 0+      Just aid -> do+        b <- getsState $ getActorBody aid+        getsState $ snd . calculateTotal b+  let stdRuleset = Kind.stdRuleset corule+      scoresFile = rscoresFile stdRuleset+  dataDir <- liftIO appDataDir+  -- Re-read the table in case it's changed by a concurrent game.+  table <- restoreScore cops+  time <- getsState stime+  date <- liftIO getClockTime+  DebugModeSer{sdifficultySer} <- getsServer sdebugSer+  factionD <- getsState sfactionD+  fightsSpawners <- fightsAgainstSpawners fid+  let path = dataDir </> scoresFile+      outputScore (worthMentioning, (ntable, pos)) =+        -- If not human, probably debugging, so dump instead of registering.+        if not $ playerAI $ gplayer fact then+          if worthMentioning then+            liftIO $ encodeEOF path (ntable :: HighScore.ScoreTable)+          else return ()+        else+          debugPrint $ T.intercalate "\n"+          $ HighScore.showScore (pos, HighScore.getRecord pos ntable)+      diff | not $ playerUI $ gplayer fact = difficultyDefault+           | otherwise = sdifficultySer+      theirVic (fi, fa) | isAtWar fact fi+                          && not (isHorrorFact cops fa) = Just $ gvictims fa+                        | otherwise = Nothing+      theirVictims = EM.unionsWith (+) $ mapMaybe theirVic $ EM.assocs factionD+      ourVic (fi, fa) | isAllied fact fi || fi == fid = Just $ gvictims fa+                      | otherwise = Nothing+      ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD+      registeredScore =+        HighScore.register table total time status date diff+                           (playerName $ gplayer fact)+                           ourVictims theirVictims fightsSpawners+  outputScore registeredScore++resetSessionStart :: MonadServer m => m ()+resetSessionStart = do+  sstart <- liftIO getClockTime+  modifyServer $ \ser -> ser {sstart}++-- TODO: all this breaks when games are loaded; we'd need to save+-- elapsed game clock time to fix this.+resetGameStart :: MonadServer m => m ()+resetGameStart = do+  sgstart <- liftIO getClockTime+  time <- getsState stime+  modifyServer $ \ser ->+    ser {sgstart, sallTime = absoluteTimeAdd (sallTime ser) time}++elapsedSessionTimeGT :: MonadServer m => Int -> m Bool+elapsedSessionTimeGT stopAfter = do+  current <- liftIO getClockTime+  TOD s p <- getsServer sstart+  return $! TOD (s + fromIntegral stopAfter) p <= current++tellAllClipPS :: MonadServer m => m ()+tellAllClipPS = do+  bench <- getsServer $ sbenchmark . sdebugSer+  when bench $ do+    TOD s p <- getsServer sstart+    TOD sCur pCur <- liftIO getClockTime+    allTime <- getsServer sallTime+    gtime <- getsState stime+    let time = absoluteTimeAdd allTime gtime+    let diff = fromIntegral sCur + fromIntegral pCur / 10e12+               - fromIntegral s - fromIntegral p / 10e12+        cps = fromIntegral (timeFit time timeClip) / diff :: Double+    debugPrint $ "Session time:" <+> tshow diff <> "s."+                 <+> "Average clips per second:" <+> tshow cps <> "."++tellGameClipPS :: MonadServer m => m ()+tellGameClipPS = do+  bench <- getsServer $ sbenchmark . sdebugSer+  when bench $ do+    TOD s p <- getsServer sgstart+    unless (s == 0) $ do  -- loaded game, don't report anything+      TOD sCur pCur <- liftIO getClockTime+      time <- getsState stime+      let diff = fromIntegral sCur + fromIntegral pCur / 10e12+                 - fromIntegral s - fromIntegral p / 10e12+          cps = fromIntegral (timeFit time timeClip) / diff :: Double+      debugPrint $ "Game time:" <+> tshow diff <> "s."+                   <+> "Average clips per second:" <+> tshow cps <> "."++tryRestore :: MonadServer m+           => Kind.COps -> DebugModeSer -> m (Maybe (State, StateServer))+tryRestore Kind.COps{corule} sdebugSer = do+  let stdRuleset = Kind.stdRuleset corule+      scoresFile = rscoresFile stdRuleset+      pathsDataFile = rpathsDataFile stdRuleset+      prefix = ssavePrefixSer sdebugSer+  let copies = [( "GameDefinition" </> scoresFile+                , scoresFile )]+      name = fromMaybe "save" prefix <.> saveName+  liftIO $ Save.restoreGame name copies pathsDataFile++-- | Compute and insert auxiliary optimized components into game content,+-- to be used in time-critical sections of the code.+speedupCOps :: Bool -> Kind.COps -> Kind.COps+speedupCOps allClear copsSlow@Kind.COps{cotile=tile} =+  let ospeedup = Tile.speedup allClear tile+      cotile = tile {Kind.ospeedup = Just ospeedup}+  in copsSlow {Kind.cotile = cotile}++-- | Invoke pseudo-random computation with the generator kept in the state.+rndToAction :: MonadServer m => Rnd a -> m a+rndToAction r = do+  g <- getsServer srandom+  let (a, ng) = St.runState r g+  modifyServer $ \ser -> ser {srandom = ng}+  return $! a++-- | Gets a random generator from the arguments or, if not present,+-- generates one.+getSetGen :: MonadServer m+          => Maybe R.StdGen+          -> m R.StdGen+getSetGen mrng = case mrng of+  Just rnd -> return rnd+  Nothing -> liftIO $ R.newStdGen
+ Game/LambdaHack/Server/PeriodicServer.hs view
@@ -0,0 +1,260 @@+-- | Server operations performed periodically in the game loop+-- and related operations.+module Game.LambdaHack.Server.PeriodicServer+  ( spawnMonster, addAnyActor, dominateFidSfx, advanceTime, leadLevelFlip+  ) where++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.Atomic+import qualified Game.LambdaHack.Common.Ability as Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Frequency+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Perception+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.ModeKind+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++-- TODO: civilians would have 'it' pronoun+-- | Sapwn, possibly, a monster according to the level's actor groups.+-- 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 -> isSpawnFact $ sfactionD s EM.! fid+  spawns <- getsState $ actorRegularList f lid+  totalDepth <- getsState stotalDepth+  -- We do not check @playerSpawn@ of any faction, but just take @lactorFreq@.+  Level{ldepth, lactorFreq} <- getLevel lid+  rc <- rndToAction $ monsterGenChance ldepth totalDepth (length spawns)+  when rc $ do+    time <- getsState $ getLocalTime lid+    maid <- addAnyActor lactorFreq lid time Nothing+    case maid of+      Nothing -> return ()+      Just aid -> do+        b <- getsState $ getActorBody aid+        mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD+        when (isNothing mleader) $+          execUpdAtomic $ UpdLeadFaction (bfid b) Nothing (Just aid)++addAnyActor :: (MonadAtomic m, MonadServer m)+            => Freqs -> LevelId -> Time -> Maybe Point+            -> m (Maybe ActorId)+addAnyActor actorFreq lid time mpos = do+  -- 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 sdiscoRev+  totalDepth <- getsState stotalDepth+  lvl@Level{ldepth} <- getLevel lid+  factionD <- getsState sfactionD+  m4 <- rndToAction+        $ newItem cops flavour discoRev actorFreq lid ldepth totalDepth+  case m4 of+    Nothing -> return Nothing+    Just (itemKnown, trunkFull, seed, k, _) -> do+      let ik = maybe (assert `failure` trunkFull) itemKind $ itemDisco trunkFull+          freqNames = map fst $ ifreq ik+          f fact = playerFaction (gplayer fact)+          factNames = map f $ EM.elems factionD+          fidName = case freqNames `intersect` factNames of+            [] -> head factNames  -- fall back to an arbitrary faction+            fName : _ -> fName+          g (_, fact) = playerFaction (gplayer fact) == fidName+          mfid = find g $ EM.assocs factionD+          fid = fst $ fromMaybe (assert `failure` (factionD, fidName)) mfid+      pers <- getsServer sper+      let allPers = ES.unions $ map (totalVisible . (EM.! lid))+                    $ EM.elems $ EM.delete fid pers  -- expensive :(+      pos <- case mpos of+        Just pos -> return pos+        Nothing -> do+          rollPos <- getsState $ rollSpawnPos cops allPers lid lvl fid+          rndToAction rollPos+      let container = (CTrunk fid lid pos)+      trunkId <- registerItem itemKnown seed k container False+      addActorIid trunkId trunkFull fid pos lid id "it" time++rollSpawnPos :: Kind.COps -> ES.EnumSet Point+             -> LevelId -> Level -> FactionId -> 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+      as = actorList (const True) lid s+      isLit = Tile.isLit cotile+      distantAtLeast d p _ =+        all (\b -> chessDist (bpos b) p > d) inhabitants+  -- Not considering F.OftenActor, because monsters emerge from hidden ducts,+  -- which are easier to hide in crampy corridors that lit halls.+  findPosTry 100 ltile+    ( \p t -> Tile.isWalkable cotile t+              && not (Tile.hasFeature cotile F.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+    ]+dominateFidSfx :: (MonadAtomic m, MonadServer m)+               => FactionId -> ActorId -> m Bool+dominateFidSfx fid target = do+  actorSk <- actorSkillsServer target (Just target)+  let canMove = EM.findWithDefault 0 Ability.AbMove actorSk > 0+  if canMove+    then do+      tb <- getsState $ getActorBody target+      let execSfx = execSfxAtomic+                    $ SfxEffect (boldfid tb) target Effect.Dominate+      execSfx+      dominateFid fid target+      execSfx+      return True+    else+      return False++dominateFid :: (MonadAtomic m, MonadServer m)+            => FactionId -> ActorId -> m ()+dominateFid fid target = do+  Kind.COps{cotile} <- getsState scops+  tb0 <- getsState $ getActorBody target+  -- Only record the initial domination as a kill.+  disco <- getsServer sdisco+  trunk <- getsState $ getItemBody $ btrunk tb0+  let ikind = disco 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+  ais <- getsState $ getCarriedAssocs tb+  calmMax <- sumOrganEqpServer Effect.EqpSlotAddMaxCalm target+  execUpdAtomic $ UpdLoseActor target tb ais+  let bNew = tb { bfid = fid+                , boldfid = bfid tb+                , bcalm = max 0 $ xM calmMax `div` 2 }+  execUpdAtomic $ UpdSpotActor target bNew ais+  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+    Nothing -> return False+    Just leaderOld -> do+      body <- getsState $ getActorBody leaderOld+      lvl <- getLevel $ blid body+      return $! Tile.isStair cotile $ lvl `at` bpos body+  unless keepLeader $+    -- Focus on the dominated actor, by making him a leader.+    execUpdAtomic $ UpdLeadFaction fid mleaderOld (Just target)++-- | 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).+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+  unless (bproj b) $ do+    dominated <-+      if bcalm b == 0+         && boldfid b /= bfid b+         && playerLeader (gplayer fact)  -- animals never Calm-dominated+      then dominateFidSfx (boldfid b) aid+      else return False+    unless dominated $ do+      newCalmDelta <- getsState $ regenCalmDelta b activeItems+      let clearMark = 0+      unless (newCalmDelta <= 0) $+        -- Update delta for the current player turn.+        execUpdAtomic $ UpdRefillCalm aid newCalmDelta+      unless (bcalmDelta b == ResDelta 0 0) $+        -- Clear delta for the next player turn.+        execUpdAtomic $ UpdRefillCalm aid clearMark+      unless (bhpDelta b == ResDelta 0 0) $+        -- Clear delta for the next player turn.+        execUpdAtomic $ UpdRefillHP aid clearMark++leadLevelFlip :: (MonadAtomic m, MonadServer m) => m ()+leadLevelFlip = do+  cops@Kind.COps{cotile} <- getsState scops+  let canFlip fact =+        -- We don't have to check @playerLeader@: @gleader@ would be @Nothing@.+        playerAI (gplayer fact) || isAllMoveFact cops fact+      flipFaction fact | not $ canFlip fact = return ()+      flipFaction fact = do+        case gleader fact of+          Nothing -> return ()+          Just leader -> do+            body <- getsState $ getActorBody leader+            lvl2 <- getLevel $ blid body+            let leaderStuck = waitedLastTurn body+                t = lvl2 `at` bpos body+            -- Keep the leader: he is on stairs and not stuck+            -- and we don't want to clog stairs or get pushed to another level.+            unless (not leaderStuck && Tile.isStair cotile t) $ do+              actorD <- getsState sactorD+              let ourLvl (lid, lvl) =+                    ( lid+                    , EM.size (lfloor lvl)+                    , -- Drama levels skipped, hence @Regular@.+                      actorRegularAssocsLvl (== bfid body) lvl actorD )+              ours <- getsState $ map ourLvl . EM.assocs . sdungeon+              -- Non-humans, being born in the dungeon, have a rough idea of+              -- the number of items left on the level and will focus+              -- on levels they started exploring and that have few items+              -- left. This is to to explore them completely, leave them+              -- once and for all and concentrate forces on another level.+              -- In addition, sole stranded actors tend to become leaders+              -- so that they can join the main force ASAP.+              let freqList = [ (k, (lid, a))+                             | (lid, itemN, (a, _) : rest) <- ours+                             , not leaderStuck || lid /= blid body+                             , let len = 1 + (min 10 $ length rest)+                                   k = 1000000 `div` (3 * itemN + len) ]+              unless (null freqList) $ do+                (lid, a) <- rndToAction $ frequency+                                        $ toFreq "leadLevel" freqList+                unless (lid == blid body) $  -- flip levels rather than actors+                  execUpdAtomic+                  $ UpdLeadFaction (bfid body) (Just leader) (Just a)+  factionD <- getsState sfactionD+  mapM_ flipFaction $ EM.elems factionD
+ Game/LambdaHack/Server/ProtocolServer.hs view
@@ -0,0 +1,219 @@+-- | The server definitions for the server-client communication protocol.+module Game.LambdaHack.Server.ProtocolServer+  ( -- * The communication channels+    ChanServer(..)+  , ConnServerDict  -- exposed only to be implemented, not used+    -- * The server-client communication monad+  , MonadServerReadRequest+      ( getDict  -- exposed only to be implemented, not used+      , getsDict  -- exposed only to be implemented, not used+      , modifyDict  -- exposed only to be implemented, not used+      , putDict  -- exposed only to be implemented, not used+      , liftIO  -- exposed only to be implemented, not used+      )+    -- * Protocol+  , sendUpdateAI, sendQueryAI, sendPingAI+  , sendUpdateUI, sendQueryUI, sendPingUI+    -- * Assorted+  , killAllClients, childrenServer, updateConn+  ) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM (TQueue, atomically)+import qualified Control.Concurrent.STM as STM+import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Data.EnumMap.Strict as EM+import Data.Key (mapWithKeyM, mapWithKeyM_)+import Game.LambdaHack.Common.Thread+import System.IO.Unsafe (unsafePerformIO)++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Request+import Game.LambdaHack.Common.Response+import Game.LambdaHack.Common.State+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Server.DebugServer+import Game.LambdaHack.Server.MonadServer hiding (liftIO)+import Game.LambdaHack.Server.State++-- | Connection channel between the server and a single client.+data ChanServer resp req = ChanServer+  { responseS :: !(TQueue resp)+  , requestS  :: !(TQueue req)+  }++-- | Connections to the human-controlled client of a faction and+-- to the AI client for the same faction.+type ConnServerFaction = ( Maybe (ChanServer ResponseUI RequestUI)+                         , ChanServer ResponseAI RequestAI )++-- | Connection information for all factions, indexed by faction identifier.+type ConnServerDict = EM.EnumMap FactionId ConnServerFaction++-- TODO: refactor so that the monad is split in 2 and looks analogously+-- to the Client monads. Restrict the Dict to implementation modules.+-- Then on top of that implement sendQueryAI, etc.+-- For now we call it MonadServerReadRequest+-- though it also has the functionality of MonadServerWriteResponse.++-- | The server monad with the ability to communicate with clients.+class MonadServer m => MonadServerReadRequest m where+  getDict      :: m ConnServerDict+  getsDict     :: (ConnServerDict -> a) -> m a+  modifyDict   :: (ConnServerDict -> ConnServerDict) -> m ()+  putDict      :: ConnServerDict -> m ()+  liftIO       :: IO a -> m a++writeTQueueAI :: MonadServerReadRequest m+              => ResponseAI -> TQueue ResponseAI -> m ()+writeTQueueAI cmd responseS = do+  debug <- getsServer $ sniffOut . sdebugSer+  when debug $ debugResponseAI cmd+  liftIO $ atomically $ STM.writeTQueue responseS cmd++writeTQueueUI :: MonadServerReadRequest m+              => ResponseUI -> TQueue ResponseUI -> m ()+writeTQueueUI cmd responseS = do+  debug <- getsServer $ sniffOut . sdebugSer+  when debug $ debugResponseUI cmd+  liftIO $ atomically $ STM.writeTQueue responseS cmd++readTQueueAI :: MonadServerReadRequest m+             => TQueue RequestAI -> m RequestAI+readTQueueAI requestS = liftIO $ atomically $ STM.readTQueue requestS++readTQueueUI :: MonadServerReadRequest m+             => TQueue RequestUI -> m RequestUI+readTQueueUI requestS = liftIO $ atomically $ STM.readTQueue requestS++sendUpdateAI :: MonadServerReadRequest m+             => FactionId -> ResponseAI -> m ()+sendUpdateAI fid cmd = do+  conn <- getsDict $ snd . (EM.! fid)+  writeTQueueAI cmd $ responseS conn++sendQueryAI :: MonadServerReadRequest m+            => FactionId -> ActorId -> m RequestAI+sendQueryAI fid aid = do+  conn <- getsDict $ snd . (EM.! fid)+  writeTQueueAI (RespQueryAI aid) $ responseS conn+  req <- readTQueueAI $ requestS conn+  debug <- getsServer $ sniffIn . sdebugSer+  when debug $ debugRequestAI aid req+  return $! req++sendPingAI :: (MonadAtomic m, MonadServerReadRequest m)+           => FactionId -> m ()+sendPingAI fid = do+  conn <- getsDict $ snd . (EM.! fid)+  writeTQueueAI RespPingAI $ responseS conn+  -- debugPrint $ "AI client" <+> tshow fid <+> "pinged..."+  cmdPong <- readTQueueAI $ requestS conn+  -- debugPrint $ "AI client" <+> tshow fid <+> "responded."+  case cmdPong of+    ReqAIPong -> return ()+    _ -> assert `failure` (fid, cmdPong)++sendUpdateUI :: MonadServerReadRequest m+             => FactionId -> ResponseUI -> m ()+sendUpdateUI fid cmd = do+  cs <- getsDict $ fst . (EM.! fid)+  case cs of+    Nothing -> assert `failure` "no channel for faction" `twith` fid+    Just conn ->+      writeTQueueUI cmd $ responseS conn++sendQueryUI :: (MonadAtomic m, MonadServerReadRequest m)+            => FactionId -> ActorId -> m RequestUI+sendQueryUI fid aid = do+  cs <- getsDict $ fst . (EM.! fid)+  case cs of+    Nothing -> assert `failure` "no channel for faction" `twith` fid+    Just conn -> do+      writeTQueueUI RespQueryUI $ responseS conn+      req <- readTQueueUI $ requestS conn+      debug <- getsServer $ sniffIn . sdebugSer+      when debug $ debugRequestUI aid req+      return $! req++sendPingUI :: (MonadAtomic m, MonadServerReadRequest m)+           => FactionId -> m ()+sendPingUI fid = do+  cs <- getsDict $ fst . (EM.! fid)+  case cs of+    Nothing -> assert `failure` "no channel for faction" `twith` fid+    Just conn -> do+      writeTQueueUI RespPingUI $ responseS conn+      -- debugPrint $ "UI client" <+> tshow fid <+> "pinged..."+      cmdPong <- readTQueueUI $ requestS conn+      -- debugPrint $ "UI client" <+> tshow fid <+> "responded."+      case cmdPong of+        ReqUIPong ats -> mapM_ execAtomic ats+        _ -> assert `failure` (fid, cmdPong)++killAllClients :: (MonadAtomic m, MonadServerReadRequest m) => m ()+killAllClients = do+  d <- getDict+  let sendKill fid _ = do+        -- We can't check in sfactionD, because client can be from an old game.+        when (fromEnum fid > 0) $+          sendUpdateUI fid $ RespUpdAtomicUI $ UpdKillExit fid+        sendUpdateAI fid $ RespUpdAtomicAI $ UpdKillExit fid+  mapWithKeyM_ sendKill d++-- Global variable for all children threads of the server.+childrenServer :: MVar [Async ()]+{-# NOINLINE childrenServer #-}+childrenServer = unsafePerformIO (newMVar [])++-- | Update connections to the new definition of factions.+-- Connect to clients in old or newly spawned threads+-- that read and write directly to the channels.+updateConn :: (MonadAtomic m, MonadServerReadRequest m)+           => (FactionId+               -> ChanServer ResponseUI RequestUI+               -> IO ())+           -> (FactionId+               -> ChanServer ResponseAI RequestAI+               -> IO ())+           -> m ()+updateConn executorUI executorAI = do+  -- Prepare connections based on factions.+  oldD <- getDict+  let mkChanServer :: IO (ChanServer resp req)+      mkChanServer = do+        responseS <- STM.newTQueueIO+        requestS <- STM.newTQueueIO+        return $! ChanServer{..}+      addConn :: FactionId -> Faction -> IO ConnServerFaction+      addConn fid fact = case EM.lookup fid oldD of+        Just conns -> return conns  -- share old conns and threads+        Nothing | playerUI $ gplayer fact -> do+          connS <- mkChanServer+          connAI <- mkChanServer+          return (Just connS, connAI)+        Nothing -> do+          connAI <- mkChanServer+          return (Nothing, connAI)+  factionD <- getsState sfactionD+  d <- liftIO $ mapWithKeyM addConn factionD+  let newD = d `EM.union` oldD  -- never kill old clients+  putDict newD+  -- Spawn client threads.+  let toSpawn = newD EM.\\ oldD+  let forkUI fid connS =+        forkChild childrenServer $ executorUI fid connS+      forkAI fid connS =+        forkChild childrenServer $ executorAI fid connS+      forkClient fid (connUI, connAI) = do+        -- When a connection is reused, clients are not respawned,+        -- 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+  liftIO $ mapWithKeyM_ forkClient toSpawn
− Game/LambdaHack/Server/ServerSem.hs 
@@ -1,521 +0,0 @@--- | Semantics of 'CmdSer' server commands.--- A couple of them do not take time, the rest does.--- Note that since the results are atomic commands, which are executed--- only later (on the server and some of the clients), all condition--- are checkd by the semantic functions in the context of the state--- before the server command. Even if one or more atomic actions--- are already issued by the point an expression is evaluated, they do not--- influence the outcome of the evaluation.--- TODO: document-module Game.LambdaHack.Server.ServerSem where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Data.EnumMap.Strict as EM-import Data.Key (mapWithKeyM_)-import Data.Maybe-import Data.Ratio-import Data.Text (Text)-import qualified NLP.Miniutter.English as MU--import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Animation-import Game.LambdaHack.Common.AtomicCmd-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Effect-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.ServerCmd-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ActorKind-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.TileKind as TileKind-import Game.LambdaHack.Server.Action hiding (sendQueryAI, sendQueryUI,-                                      sendUpdateAI, sendUpdateUI)-import Game.LambdaHack.Server.EffectSem-import Game.LambdaHack.Server.State--execFailure :: (MonadAtomic m, MonadServer m)-            => ActorId -> FailureSer -> m ()-execFailure aid failureSer = do-  -- Clients should rarely do that (only in case of invisible actors)-  -- so we report it, send a --more-- meeesage (if not AI), but do not crash-  -- (server should work OK with stupid clients, too).-  body <- getsState $ getActorBody aid-  let fid = bfid body-      msg = showFailureSer failureSer-  debugPrint-    $ "execFailure:" <+> tshow fid <+> ":" <+> msg <> "\n" <> tshow body-  execSfxAtomic $ MsgFidD fid $ "Unexpected problem:" <+> msg <> "."-    -- TODO: --more--, but keep in history--broadcastCmdAtomic :: MonadAtomic m-                   => (FactionId -> CmdAtomic) -> m ()-broadcastCmdAtomic fcmd = do-  factionD <- getsState sfactionD-  mapWithKeyM_ (\fid _ -> execCmdAtomic $ fcmd fid) factionD--broadcastSfxAtomic :: MonadAtomic m-                   => (FactionId -> SfxAtomic) -> m ()-broadcastSfxAtomic fcmd = do-  factionD <- getsState sfactionD-  mapWithKeyM_ (\fid _ -> execSfxAtomic $ fcmd fid) factionD---- * MoveSer---- TODO: let only some actors/items leave smell, e.g., a Smelly Hide Armour.--- | Add a smell trace for the actor to the level. For now, only heroes--- leave smell.-addSmell :: MonadAtomic m => ActorId -> m ()-addSmell aid = do-  cops@Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  let canSmell = asmell $ okind $ bkind b-  unless (bproj b || not (isHeroFact cops fact) || canSmell) $ do-    time <- getsState $ getLocalTime $ blid b-    lvl <- getLevel $ blid b-    let oldS = EM.lookup (bpos b) . lsmell $ lvl-        newTime = timeAdd time smellTimeout-    execCmdAtomic $ AlterSmellA (blid b) (bpos b) oldS (Just newTime)---- | Actor moves or attacks.--- Note that client may not be able to see an invisible monster--- so it's the server that determines if melee took place, etc.--- Also, only the server is authorized to check if a move is legal--- and it needs full context for that, e.g., the initial actor position--- to check if melee attack does not try to reach to a distant tile.-moveSer :: (MonadAtomic m, MonadServer m) => ActorId -> Vector -> m ()-moveSer source dir = do-  cops <- 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-  -- We start by checking actors at the the target position.-  tgt <- getsState $ posToActor tpos lid-  case tgt of-    Just ((target, tb), _) | not (bproj sb && bproj tb) ->  -- visible or not-      -- Attacking does not require full access, adjacency is enough.-      -- Projectiles are too small to hit each other.-      meleeSer source target-    _-      | accessible cops lvl spos tpos -> do-          -- Movement requires full access.-          execCmdAtomic $ MoveActorA source spos tpos-          addSmell source-      | otherwise ->-          -- Client foolishly tries to move into blocked, boring tile.-          execFailure source MoveNothing---- * MeleeSer---- | Resolves the result of an actor moving into another.--- Actors on blocked positions can be attacked without any restrictions.--- For instance, an actor embedded in a wall can be attacked from--- an adjacent position. This function is analogous to projectGroupItem,--- but for melee and not using up the weapon.--- No problem if there are many projectiles at the spot. We just--- attack the one specified.-meleeSer :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()-meleeSer source target = do-  cops@Kind.COps{coitem=coitem@Kind.Ops{opick, okind}} <- getsState scops-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  let adj = checkAdjacent sb tb-  if source == target then execFailure source MeleeSelf-  else if not adj then execFailure source MeleeDistant-  else do-    let sfid = bfid sb-        tfid = bfid tb-    sfact <- getsState $ (EM.! sfid) . sfactionD-    itemAssocs <- getsState $ getActorItem source-    (miid, item) <--      if bproj sb   -- projectile-      then case itemAssocs of-        [(iid, item)] -> return (Just iid, item)-        _ -> assert `failure` "projectile with wrong items" `twith` itemAssocs-      else case strongestSword cops itemAssocs of-        Just (_, (iid, w)) -> return (Just iid, w)  -- weapon combat-        Nothing -> do  -- hand to hand combat-          let isHero = isHeroFact cops sfact-              h2hGroup | isHero = "unarmed"-                       | otherwise = "monstrous"-          h2hKind <- rndToAction $ fmap (fromMaybe $ assert `failure` h2hGroup)-                                   $ opick h2hGroup (const True)-          flavour <- getsServer sflavour-          discoRev <- getsServer sdiscoRev-          let kind = okind h2hKind-          let kindEffect = case causeIEffects coitem h2hKind of-                [] -> NoEffect-                eff : _TODO -> eff-              effect = fmap maxDeep kindEffect-          return ( Nothing-                 , buildItem flavour discoRev h2hKind kind effect )-    let performHit block = do-          let hitA = if block then HitBlockD else HitD-          execSfxAtomic $ StrikeD source target item hitA-          -- Deduct a hitpoint for a pierce of a projectile.-          when (bproj sb) $ execCmdAtomic $ HealActorA source (-1)-          -- Msgs inside itemEffect describe the target part.-          itemEffect source target miid item-    -- Projectiles can't be blocked (though can be sidestepped).-    -- Incapacitated actors can't block.-    if braced tb && not (bproj sb) && bhp tb > 0-      then do-        blocked <- rndToAction $ chance $ 1%2-        if blocked-          then execSfxAtomic $ StrikeD source target item MissBlockD-          else performHit True-      else performHit False-    -- The only way to start a war is to slap an enemy. Being hit by-    -- and hitting projectiles count as unintentional friendly fire.-    let friendlyFire = bproj sb || bproj tb-        fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)-    unless (friendlyFire || isAtWar sfact tfid || sfid == tfid) $-      execCmdAtomic $ DiplFactionA sfid tfid fromDipl War---- * DisplaceSer---- | Actor tries to swap positions with another.-displaceSer :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m ()-displaceSer source target = do-  cops <- getsState scops-  sb <- getsState $ getActorBody source-  tb <- getsState $ getActorBody target-  let adj = checkAdjacent sb tb-  if not adj then execFailure source DisplaceDistant-  else do-    let lid = blid sb-    lvl <- getLevel lid-    let spos = bpos sb-        tpos = bpos tb-    -- Displacing requires full access.-    if accessible cops lvl spos tpos then do-      tgts <- getsState $ posToActors tpos lid-      case tgts of-        [] -> assert `failure` (source, sb, target, tb)-        [_] -> do-          execCmdAtomic $ DisplaceActorA source target-          addSmell source-          addSmell target-        _ -> execFailure source DisplaceProjectiles-    else do-      -- Client foolishly tries to displace an actor without access.-      execFailure source DisplaceAccess---- * AlterSer---- | Search and/or alter the tile.------ Note that if @serverTile /= freshClientTile@, @freshClientTile@--- should not be alterable (but @serverTile@ may be).-alterSer :: (MonadAtomic m, MonadServer m)-         => ActorId -> Point -> Maybe F.Feature -> m ()-alterSer source tpos mfeat = do-  Kind.COps{cotile=cotile@Kind.Ops{okind, opick}} <- getsState scops-  sb <- getsState $ getActorBody source-  let lid = blid sb-      spos = bpos sb-  if not $ adjacent spos tpos then execFailure source AlterDistant-  else do-    lvl <- getLevel lid-    let serverTile = lvl `at` tpos-        freshClientTile = hideTile cotile lvl tpos-        changeTo tgroup = do-          -- No AlterD, because the effect is obvious (e.g., opened door).-          toTile <- rndToAction $ fmap (fromMaybe $ assert `failure` tgroup)-                                  $ opick tgroup (const True)-          unless (toTile == serverTile) $-            execCmdAtomic $ AlterTileA lid tpos serverTile toTile-        feats = case mfeat of-          Nothing -> TileKind.tfeature $ okind serverTile-          Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]-          Just _ -> []-        toAlter feat =-          case feat of-            F.OpenTo tgroup -> Just tgroup-            F.CloseTo tgroup -> Just tgroup-            F.ChangeTo tgroup -> Just tgroup-            _ -> Nothing-        groupsToAlter = mapMaybe toAlter feats-    as <- getsState $ actorList (const True) lid-    if null groupsToAlter && serverTile == freshClientTile then-      -- Neither searching nor altering possible; silly client.-      execFailure source AlterNothing-    else do-      if EM.null $ lvl `atI` tpos then-        if unoccupied as tpos then do-          when (serverTile /= freshClientTile) $ do-            -- Search, in case some actors (of other factions?)-            -- don't know this tile.-            execCmdAtomic $ SearchTileA source tpos freshClientTile serverTile-          mapM_ changeTo groupsToAlter-          -- Perform an effect, if any permitted.-          void $ triggerEffect source feats-        else execFailure source AlterBlockActor-      else execFailure source AlterBlockItem---- * WaitSer---- | Do nothing.------ Something is sometimes done in 'LoopAction.setBWait'.-waitSer :: MonadAtomic m => ActorId -> m ()-waitSer _ = return ()---- * PickupSer--pickupSer ::  (MonadAtomic m, MonadServer m)-          => ActorId -> ItemId -> Int -> m ()-pickupSer aid iid k = assert (k > 0) $ do-  b <- getsState $ getActorBody aid-  item <- getsState $ getItemBody iid-  case actorContainerB aid b iid item of-    Just c -> execCmdAtomic $ MoveItemA iid k (CFloor (blid b) (bpos b)) c-    Nothing -> execFailure aid PickupOverfull---- * DropSer--dropSer :: MonadAtomic m => ActorId -> ItemId -> Int -> m ()-dropSer aid iid k = assert (k > 0) $ do-  b <- getsState $ getActorBody aid-  let c = actorContainer aid (binv b) iid-  execCmdAtomic $ MoveItemA iid k c (CFloor (blid b) (bpos b))---- * ProjectSer--projectSer :: (MonadAtomic m, MonadServer m)-           => ActorId    -- ^ actor projecting the item (is on current lvl)-           -> Point    -- ^ target position of the projectile-           -> Int        -- ^ digital line parameter-           -> ItemId     -- ^ the item to be projected-           -> Container  -- ^ whether the items comes from floor or inventory-           -> m ()-projectSer source tpxy eps iid container = do-  mfail <- projectFail source tpxy eps iid container False-  maybe skip (execFailure source) mfail--projectFail :: (MonadAtomic m, MonadServer m)-            => ActorId    -- ^ actor projecting the item (is on current lvl)-            -> Point      -- ^ target position of the projectile-            -> Int        -- ^ digital line parameter-            -> ItemId     -- ^ the item to be projected-            -> Container  -- ^ whether the items comes from floor or inventory-            -> Bool       -- ^ whether the item is a shrapnel-            -> m (Maybe FailureSer)-projectFail source tpxy eps iid container isShrapnel = do-  Kind.COps{coactor=Kind.Ops{okind}, cotile} <- getsState scops-  sb <- getsState $ getActorBody source-  let lid = blid sb-      spos = bpos sb-  lvl@Level{lxsize, lysize} <- getLevel lid-  case bla lxsize lysize eps spos tpxy of-    Nothing -> return $ Just ProjectAimOnself-    Just [] -> assert `failure` "projecting from the edge of level"-                      `twith` (spos, tpxy)-    Just (pos : rest) -> do-      let t = lvl `at` pos-      if not $ Tile.isClear cotile t-        then return $ Just ProjectBlockTerrain-        else do-          mab <- getsState $ posToActor pos lid-          if not $ maybe True (bproj . snd . fst) mab-            then-              if isShrapnel then do-                -- Hit the blocking actor.-                projectBla source spos (pos : rest) iid container-                return Nothing-              else return $ Just ProjectBlockActor-            else do-              blockedByFoes <--                if isShrapnel then return False-                else do-                  fact <- getsState $ (EM.! bfid sb) . sfactionD-                  foes <- getsState $ actorNotProjList (isAtWar fact) lid-                  return $! foesAdjacent lxsize lysize spos foes-              if blockedByFoes then-                return $ Just ProjectBlockFoes-              else if not (asight (okind $ bkind sb) || bproj sb)-                   then return $ Just ProjectBlind-                   else do-                    if isShrapnel && eps `mod` 2 == 0 then-                      -- Make the explosion a bit less regular.-                      projectBla source spos (pos:rest) iid container-                    else-                      projectBla source pos rest iid container-                    return Nothing--projectBla :: (MonadAtomic m, MonadServer m)-           => ActorId    -- ^ actor projecting the item (is on current lvl)-           -> Point      -- ^ starting point of the projectile-           -> [Point]    -- ^ rest of the trajectory of the projectile-           -> ItemId     -- ^ the item to be projected-           -> Container  -- ^ whether the items comes from floor or inventory-           -> m ()-projectBla source pos rest iid container = do-  sb <- getsState $ getActorBody source-  let lid = blid sb-      time = btime sb-  unless (bproj sb) $ execSfxAtomic $ ProjectD source iid-  projId <- addProjectile pos rest iid lid (bfid sb) time-  execCmdAtomic $ MoveItemA iid 1 container (CActor projId (InvChar 'a'))---- | Create a projectile actor containing the given missile.-addProjectile :: (MonadAtomic m, MonadServer m)-              => Point -> [Point] -> ItemId -> LevelId -> FactionId -> Time-              -> m ActorId-addProjectile bpos rest iid blid bfid btime = do-  Kind.COps{ coactor=coactor@Kind.Ops{okind}-           , coitem=coitem@Kind.Ops{okind=iokind} } <- getsState scops-  disco <- getsServer sdisco-  item <- getsState $ getItemBody iid-  let lingerPercent = isLingering coitem disco item-      ik = iokind (fromJust $ jkind disco item)-      speed = speedFromWeight (jweight item) (itoThrow ik)-      range = rangeFromSpeed speed-      adj | range < 5 = "falling"-          | otherwise = "flying"-      -- Not much details about a fast flying object.-      (object1, object2) = partItem coitem EM.empty item-      name = makePhrase [MU.AW $ MU.Text adj, object1, object2]-      trajectoryLength = lingerPercent * range `div` 100-      dirTrajectory = take trajectoryLength $ pathToTrajectory (bpos : rest)-      kind = okind $ projectileKindId coactor-      m = actorTemplate (projectileKindId coactor) (asymbol kind) name-                        (acolor kind) speed 0 (Just dirTrajectory)-                        bpos blid btime bfid True-  acounter <- getsServer sacounter-  modifyServer $ \ser -> ser {sacounter = succ acounter}-  execCmdAtomic $ CreateActorA acounter m [(iid, item)]-  return $! acounter---- * ApplySer---- TODO: check actor has access to the item-applySer :: (MonadAtomic m, MonadServer m)-         => ActorId    -- ^ actor applying the item (is on current level)-         -> ItemId     -- ^ the item to be applied-         -> Container  -- ^ the location of the item-         -> m ()-applySer actor iid container = do-  item <- getsState $ getItemBody iid-  execSfxAtomic $ ActivateD actor iid-  itemEffect actor actor (Just iid) item-  -- TODO: don't destroy if not really used up; also, don't take time?-  execCmdAtomic $ DestroyItemA iid item 1 container---- * TriggerSer---- | Perform the effect specified for the tile in case it's triggered.-triggerSer :: (MonadAtomic m, MonadServer m)-           => ActorId -> Maybe F.Feature -> m ()-triggerSer aid mfeat = do-  Kind.COps{cotile=cotile@Kind.Ops{okind}} <- getsState scops-  sb <- getsState $ getActorBody aid-  let lid = blid sb-  lvl <- getLevel lid-  let tpos = bpos sb-      serverTile = lvl `at` tpos-      feats = case mfeat of-        Nothing -> TileKind.tfeature $ okind serverTile-        Just feat2 | Tile.hasFeature cotile feat2 serverTile -> [feat2]-        Just _ -> []-  go <- triggerEffect aid feats-  unless go $ execFailure aid TriggerNothing--triggerEffect :: (MonadAtomic m, MonadServer m)-              => ActorId -> [F.Feature] -> m Bool-triggerEffect aid feats = do-  sb <- getsState $ getActorBody aid-  let tpos = bpos sb-      triggerFeat feat =-        case feat of-          F.Cause ef -> do-            -- No block against tile, hence unconditional.-            execSfxAtomic $ TriggerD aid tpos feat-            void $ effectSem ef aid aid-            return True-          _ -> return False-  goes <- mapM triggerFeat feats-  return $! or goes---- * SetTrajectorySer--setTrajectorySer :: (MonadAtomic m, MonadServer m) => ActorId -> m ()-setTrajectorySer aid = do-  cops <- getsState scops-  b@Actor{bpos, btrajectory, blid, bcolor} <- getsState $ getActorBody aid-  lvl <- getLevel blid-  let clearTrajectory =-        execCmdAtomic $ TrajectoryActorA aid btrajectory (Just [])-  case btrajectory of-    Just (d : lv) ->-      if not $ accessibleDir cops lvl bpos d-      then clearTrajectory-      else do-        when (length lv <= 1) $ do-          let toColor = Color.BrBlack-          when (bcolor /= toColor) $-            execCmdAtomic $ ColorActorA aid bcolor toColor-        moveSer aid d-        execCmdAtomic $ TrajectoryActorA aid btrajectory (Just lv)-    _ -> assert `failure` "null trajectory" `twith` (aid, b)---- * GameRestart---- TODO: implement a handshake and send hero names there,--- so that they are available in the first game too,--- not only in subsequent, restarted, games.-gameRestartSer :: (MonadAtomic m, MonadServer m)-               => ActorId -> Text -> Int -> [(Int, Text)] -> m ()-gameRestartSer aid stInfo d configHeroNames = do-  modifyServer $ \ser ->-    ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d-                                     , sdebugCli = (sdebugCli (sdebugNxt ser))-                                                     {sdifficultyCli = d}-                                     }}-  b <- getsState $ getActorBody aid-  let fid = bfid b-  oldSt <- getsState $ gquit . (EM.! fid) . sfactionD-  modifyServer $ \ser ->-    ser { squit = True  -- do this at once-        , sheroNames = EM.insert fid configHeroNames $ sheroNames ser }-  revealItems Nothing Nothing-  execCmdAtomic $ QuitFactionA fid (Just b) oldSt-                $ Just $ Status Restart (fromEnum $ blid b) stInfo---- * GameExit--gameExitSer :: (MonadAtomic m, MonadServer m) => ActorId -> Int -> m ()-gameExitSer aid d = do-  modifyServer $ \ser ->-    ser {sdebugNxt = (sdebugNxt ser) { sdifficultySer = d-                                     , sdebugCli = (sdebugCli (sdebugNxt ser))-                                                     {sdifficultyCli = d}-                                     }}-  b <- getsState $ getActorBody aid-  let fid = bfid b-  oldSt <- getsState $ gquit . (EM.! fid) . sfactionD-  modifyServer $ \ser -> ser {squit = True}  -- do this at once-  execCmdAtomic $ QuitFactionA fid (Just b) oldSt-                $ Just $ Status Camping (fromEnum $ blid b) ""---- * GameSaveSer--gameSaveSer :: MonadServer m => m ()-gameSaveSer = do-  modifyServer $ \ser -> ser {sbkpSave = True}-  modifyServer $ \ser -> ser {squit = True}  -- do this at once
− Game/LambdaHack/Server/StartAction.hs 
@@ -1,283 +0,0 @@--- | Operations for starting and restarting the game.-module Game.LambdaHack.Server.StartAction-  ( applyDebug, gameReset, reinitGame, saveBkpAll, initPer-  ) where--import Control.Exception.Assert.Sugar-import Control.Monad-import qualified Control.Monad.State as St-import qualified Data.Char as Char-import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES-import Data.Key (mapWithKeyM_)-import Data.List-import qualified Data.Map.Strict as M-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import Data.Tuple (swap)-import qualified System.Random as R--import Game.LambdaHack.Common.Action-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.AtomicCmd-import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.Flavour-import qualified Game.LambdaHack.Common.HighScore as HighScore-import Game.LambdaHack.Common.Item-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State-import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Server.Action hiding (sendUpdateAI, sendUpdateUI)-import qualified Game.LambdaHack.Server.DungeonGen as DungeonGen-import Game.LambdaHack.Server.EffectSem-import Game.LambdaHack.Server.Fov-import Game.LambdaHack.Server.ServerSem-import Game.LambdaHack.Server.State---- | Apply debug options that don't need a new game.-applyDebug :: MonadServer m => m ()-applyDebug = do-  DebugModeSer{..} <- getsServer sdebugNxt-  modifyServer $ \ser ->-    ser {sdebugSer = (sdebugSer ser) { sniffIn-                                     , sniffOut-                                     , sallClear-                                     , sfovMode-                                     , sstopAfter-                                     , sdbgMsgSer-                                     , snewGameSer-                                     , sdumpInitRngs-                                     , sdebugCli }}--initPer :: MonadServer m => m ()-initPer = do-  cops <- getsState scops-  fovMode <- getsServer $ sfovMode . sdebugSer-  pers <- getsState $ dungeonPerception cops (fromMaybe (Digital 12) fovMode)-  modifyServer $ \ser1 -> ser1 {sper = pers}--reinitGame :: (MonadAtomic m, MonadConnServer m) => m ()-reinitGame = do-  Kind.COps{coitem=Kind.Ops{okind}, corule} <- getsState scops-  pers <- getsServer sper-  knowMap <- getsServer $ sknowMap . sdebugSer-  -- This state is quite small, fit for transmition to the client.-  -- The biggest part is content, which really needs to be updated-  -- at this point to keep clients in sync with server improvements.-  fromGlobal <- getsState localFromGlobal-  s <- getState-  let defLoc | knowMap = s-             | otherwise = fromGlobal-  discoS <- getsServer sdisco-  let misteriousSymbols = ritemProject $ Kind.stdRuleset corule-      sdisco = let f ik = isymbol (okind ik) `notElem` misteriousSymbols-               in EM.filter f discoS-  sdebugCli <- getsServer $ sdebugCli . sdebugSer-  modeName <- getsServer $ sgameMode . sdebugSer-  broadcastCmdAtomic-    $ \fid -> RestartA fid sdisco (pers EM.! fid) defLoc sdebugCli modeName-  populateDungeon-  saveBkpAll False---- TODO: This can be improved by adding a timeout--- and by asking clients to prepare--- a save (in this way checking they have permissions, enough space, etc.)--- and when all report back, asking them to commit the save.--- | Save game on server and all clients. Clients are pinged first,--- which greatly reduced the chance of saves being out of sync.-saveBkpAll :: (MonadAtomic m, MonadServer m, MonadConnServer m) => Bool -> m ()-saveBkpAll unconditional = do-  factionD <- getsState sfactionD-  let ping fid _ = do-        sendPingAI fid-        when (playerUI $ gplayer $ factionD EM.! fid) $ sendPingUI fid-  mapWithKeyM_ ping factionD-  bench <- getsServer $ sbenchmark . sdebugSer-  when (unconditional || not bench) $ do-    execCmdAtomic SaveBkpA-    saveServer--mapFromInvFuns :: (Bounded a, Enum a, Ord b) => [a -> b] -> M.Map b a-mapFromInvFuns =-  let fromFun f m1 =-        let invAssocs = map (\c -> (f c, c)) [minBound..maxBound]-            m2 = M.fromList invAssocs-        in m2 `M.union` m1-  in foldr fromFun M.empty--lowercase :: Text -> Text-lowercase = T.pack . map Char.toLower . T.unpack--createFactions :: Kind.COps -> Players -> Rnd FactionDict-createFactions Kind.COps{cofaction=Kind.Ops{opick}} players = do-  let rawCreate gplayer@Player{..} = do-        let cmap = mapFromInvFuns-                     [colorToTeamName, colorToPlainName, colorToFancyName]-            nameoc = lowercase playerName-            prefix | playerHuman = "Human"-                   | otherwise = "Autonomous"-            (gcolor, gname) = case M.lookup nameoc cmap of-              Nothing -> (Color.BrWhite, prefix <+> playerName)-              Just c -> (c, prefix <+> playerName <+> "Team")-        gkind <- fmap (fromMaybe $ assert `failure` playerFaction)-                 $ opick playerFaction (const True)-        let gdipl = EM.empty  -- fixed below-            gquit = Nothing-            gleader = Nothing-        return $! Faction{..}-  lUI <- mapM rawCreate $ filter playerUI $ playersList players-  lnoUI <- mapM rawCreate $ filter (not . playerUI) $ playersList players-  let lFs = reverse (zip [toEnum (-1), toEnum (-2)..] lnoUI)  -- sorted-            ++ zip [toEnum 1..] lUI-      swapIx l =-        let findPlayerName name = find ((name ==) . playerName . gplayer . snd)-            f (name1, name2) =-              case (findPlayerName name1 lFs, findPlayerName name2 lFs) of-                (Just (ix1, _), Just (ix2, _)) -> (ix1, ix2)-                _ -> assert `failure` "unknown faction"-                            `twith` ((name1, name2), lFs)-            ixs = map f l-        -- Only symmetry is ensured, everything else is permitted, e.g.,-        -- a faction in alliance with two others that are at war.-        in ixs ++ map swap ixs-      mkDipl diplMode =-        let f (ix1, ix2) =-              let adj fact = fact {gdipl = EM.insert ix2 diplMode (gdipl fact)}-              in EM.adjust adj ix1-        in foldr f-      rawFs = EM.fromDistinctAscList lFs-      -- War overrides alliance, so 'warFs' second.-      allianceFs = mkDipl Alliance rawFs (swapIx (playersAlly players))-      warFs = mkDipl War allianceFs (swapIx (playersEnemy players))-  return $! warFs--gameReset :: MonadServer m-          => Kind.COps -> DebugModeSer -> Maybe R.StdGen -> m State-gameReset cops@Kind.COps{coitem, comode=Kind.Ops{opick, okind}}-          sdebug mrandom = do-  dungeonSeed <- getSetGen $ sdungeonRng sdebug `mplus` mrandom-  srandom <- getSetGen $ smainRng sdebug `mplus` mrandom-  scoreTable <- if sbenchmark sdebug then-                  return HighScore.empty-                else-                  restoreScore cops-  sstart <- getsServer sstart  -- copy over from previous game-  sallTime <- getsServer sallTime  -- copy over from previous game-  sheroNames <- getsServer sheroNames  -- copy over from previous game-  let smode = sgameMode sdebug-      rnd :: Rnd (FactionDict, FlavourMap, Discovery, DiscoRev,-                  DungeonGen.FreshDungeon)-      rnd = do-        modeKind <- fmap (fromMaybe $ assert `failure` smode)-                    $ opick smode (const True)-        let mode = okind modeKind-        faction <- createFactions cops $ mplayers mode-        sflavour <- dungeonFlavourMap coitem-        (sdisco, sdiscoRev) <- serverDiscos coitem-        freshDng <- DungeonGen.dungeonGen cops $ mcaves mode-        return (faction, sflavour, sdisco, sdiscoRev, freshDng)-  let (faction, sflavour, sdisco, sdiscoRev, DungeonGen.FreshDungeon{..}) =-        St.evalState rnd dungeonSeed-      defState = defStateGlobal freshDungeon freshDepth faction cops scoreTable-      defSer = emptyStateServer { sstart, sallTime, sheroNames, srandom-                                , srngs = RNGs (Just dungeonSeed)-                                               (Just srandom) }-  putServer defSer-  when (sbenchmark sdebug) resetGameStart-  modifyServer $ \ser -> ser {sdisco, sdiscoRev, sflavour}-  return $! defState---- Spawn initial actors. Clients should notice this, to set their leaders.-populateDungeon :: (MonadAtomic m, MonadServer m) => m ()-populateDungeon = do-  cops@Kind.COps{cotile} <- getsState scops-  let initialItems lid (Level{ltile, litemNum, lxsize, lysize}) =-        replicateM litemNum $ do-          Level{lfloor} <- getLevel lid-          pos <- rndToAction $ findPosTry 1000 ltile-                                 -- try really hard, for skirmish fairness-                   (const (Tile.hasFeature cotile F.CanItem))-                   [ \p _ -> all (flip EM.notMember lfloor)-                             $ vicinity lxsize lysize p-                   , \p _ -> EM.notMember p lfloor-                   ]-          createItems 1 pos lid-  dungeon <- getsState sdungeon-  mapWithKeyM_ initialItems dungeon-  factionD <- getsState sfactionD-  sheroNames <- getsServer sheroNames-  let (minD, maxD) =-        case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of-          (Just ((s, _), _), Just ((e, _), _)) -> (s, e)-          _ -> assert `failure` "empty dungeon" `twith` dungeon-      needInitialCrew = filter ((> 0 ) . playerInitial . gplayer . snd)-                        $ EM.assocs factionD-      getEntryLevel (_, fact) =-        max minD $ min maxD $ playerEntry $ gplayer fact-      arenas = ES.toList $ ES.fromList $ map getEntryLevel needInitialCrew-      initialActors lid = do-        lvl <- getLevel lid-        let arenaFactions = filter ((== lid) . getEntryLevel) needInitialCrew-        entryPoss <- rndToAction-                     $ findEntryPoss cops lvl (length arenaFactions)-        mapM_ (arenaActors lid) $ zip arenaFactions entryPoss-      arenaActors _ ((_, Faction{gplayer = Player{playerInitial = 0}}), _) =-        return ()-      arenaActors lid ((side, fact), ppos) = do-        time <- getsState $ getLocalTime lid-        let nmult = fromEnum side `mod` 5  -- always positive-            ntime = timeAdd time (timeScale timeClip nmult)-            validTile t = Tile.hasFeature cotile F.CanActor t-        psFree <- getsState $ nearbyFreePoints cotile validTile ppos lid-        let ps = take (playerInitial $ gplayer fact) $ zip [0..] psFree-        forM_ ps $ \ (n, p) ->-          if not $ isHeroFact cops fact-          then spawnMonsters [p] lid ntime side-          else do-            let hNames = fromMaybe [] $ EM.lookup side sheroNames-            aid <- addHero side p lid hNames (Just n) ntime-            mleader <- getsState-                       $ gleader . (EM.! side) . sfactionD  -- just changed-            when (isNothing mleader) $-              execCmdAtomic $ LeadFactionA side Nothing (Just aid)-  mapM_ initialActors arenas---- | 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-  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-                (const (Tile.hasFeature cotile F.CanActor))-                [ dist ps $ factionDist `div` 2-                , dist ps $ factionDist `div` 3-                , dist ps $ factionDist `div` 4-                , dist ps $ factionDist `div` 8-                , dist ps $ factionDist `div` 16-                ]-        nps <- tryFind (np : ps) (n - 1)-        return $! np : nps-      stairPoss = fst lstair ++ snd lstair-      middlePos = Point (lxsize `div` 2) (lysize `div` 2)-  assert (k > 0 && factionDist > 0) skip-  case k of-    1 -> tryFind stairPoss k-    2 -> -- Make sure the first faction's pos is not chosen in the middle.-         tryFind [middlePos] k-    _ | k > 2 -> tryFind [] k-    _ -> assert `failure` k
+ Game/LambdaHack/Server/StartServer.hs view
@@ -0,0 +1,348 @@+-- | Operations for starting and restarting the game.+module Game.LambdaHack.Server.StartServer+  ( gameReset, reinitGame, initPer, recruitActors, applyDebug, initDebug+  ) where++import Control.Exception.Assert.Sugar+import Control.Monad+import qualified Control.Monad.State as St+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.Text (Text)+import qualified Data.Text as T+import Data.Tuple (swap)+import qualified System.Random as R++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.ClientOptions+import qualified Game.LambdaHack.Common.Color as Color+import qualified Game.LambdaHack.Common.Effect as Effect+import Game.LambdaHack.Common.Faction+import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Flavour+import qualified Game.LambdaHack.Common.HighScore as HighScore+import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Kind as Kind+import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.State+import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.FactionKind+import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Server.CommonServer+import qualified Game.LambdaHack.Server.DungeonGen as DungeonGen+import Game.LambdaHack.Server.Fov+import Game.LambdaHack.Server.ItemRev+import Game.LambdaHack.Server.ItemServer+import Game.LambdaHack.Server.MonadServer+import Game.LambdaHack.Server.State++initPer :: MonadServer m => m ()+initPer = do+  fovMode <- getsServer $ sfovMode . sdebugSer+  ser <- getServer+  pers <- getsState $ \s -> dungeonPerception (fromMaybe Digital fovMode) s ser+  modifyServer $ \ser1 -> ser1 {sper = pers}++reinitGame :: (MonadAtomic m, MonadServer m) => m ()+reinitGame = do+  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops+  pers <- getsServer sper+  knowMap <- getsServer $ sknowMap . 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.+  s <- getState+  let defLocal | knowMap = s+               | otherwise = localFromGlobal s+  discoS <- getsServer sdisco+  let sdisco = let f ik = Effect.Identified `elem` ifeature (okind ik)+               in EM.filter f discoS+  sdebugCli <- getsServer $ sdebugCli . sdebugSer+  modeName <- getsServer $ sgameMode . sdebugSer+  broadcastUpdAtomic+    $ \fid -> UpdRestart fid sdisco (pers EM.! fid) defLocal sdebugCli modeName+  populateDungeon++mapFromFuns :: (Bounded a, Enum a, Ord b) => [a -> b] -> M.Map b a+mapFromFuns =+  let fromFun f m1 =+        let invAssocs = map (\c -> (f c, c)) [minBound..maxBound]+            m2 = M.fromList invAssocs+        in m2 `M.union` m1+  in foldr fromFun M.empty++lowercase :: Text -> Text+lowercase = T.pack . map Char.toLower . T.unpack++createFactions :: Kind.COps -> Players -> Rnd FactionDict+createFactions Kind.COps{cofaction=Kind.Ops{opick}} players = do+  let rawCreate gplayer@Player{..} = do+        let cmap = mapFromFuns+                     [colorToTeamName, colorToPlainName, colorToFancyName]+            nameoc = lowercase $ head $ T.words playerName+            prefix | playerAI = "Autonomous"+                   | otherwise = "Controlled"+            (gcolor, gname) = case M.lookup nameoc cmap of+              Nothing -> (Color.BrWhite, prefix <+> playerName)+              Just c -> (c, prefix <+> playerName <+> "Team")+        gkind <- fmap (fromMaybe $ assert `failure` playerFaction)+                 $ opick playerFaction (const True)+        let gdipl = EM.empty  -- fixed below+            gquit = Nothing+            gleader = Nothing+            gvictims = EM.empty+            gsha = EM.empty+        return $! Faction{..}+  lUI <- mapM rawCreate $ filter playerUI $ playersList players+  lnoUI <- mapM rawCreate $ filter (not . playerUI) $ playersList players+  let lFs = reverse (zip [toEnum (-1), toEnum (-2)..] lnoUI)  -- sorted+            ++ zip [toEnum 1..] lUI+      swapIx l =+        let findPlayerName name = find ((name ==) . playerName . gplayer . snd)+            f (name1, name2) =+              case (findPlayerName name1 lFs, findPlayerName name2 lFs) of+                (Just (ix1, _), Just (ix2, _)) -> (ix1, ix2)+                _ -> assert `failure` "unknown faction"+                            `twith` ((name1, name2), lFs)+            ixs = map f l+        -- Only symmetry is ensured, everything else is permitted, e.g.,+        -- a faction in alliance with two others that are at war.+        in ixs ++ map swap ixs+      mkDipl diplMode =+        let f (ix1, ix2) =+              let adj fact = fact {gdipl = EM.insert ix2 diplMode (gdipl fact)}+              in EM.adjust adj ix1+        in foldr f+      rawFs = EM.fromDistinctAscList lFs+      -- War overrides alliance, so 'warFs' second.+      allianceFs = mkDipl Alliance rawFs (swapIx (playersAlly players))+      warFs = mkDipl War allianceFs (swapIx (playersEnemy players))+  return $! warFs++gameReset :: MonadServer m+          => Kind.COps -> DebugModeSer -> Maybe R.StdGen -> m State+gameReset cops@Kind.COps{coitem, comode=Kind.Ops{opick, okind}}+          sdebug mrandom = do+  dungeonSeed <- getSetGen $ sdungeonRng sdebug `mplus` mrandom+  srandom <- getSetGen $ smainRng sdebug `mplus` mrandom+  scoreTable <- if sfrontendNull $ sdebugCli sdebug then+                  return HighScore.empty+                else+                  restoreScore cops+  sstart <- getsServer sstart  -- copy over from previous game+  sallTime <- getsServer sallTime  -- copy over from previous game+  sheroNames <- getsServer sheroNames  -- copy over from previous game+  let smode = sgameMode sdebug+      rnd :: Rnd (FactionDict, FlavourMap, Discovery, DiscoRev,+                  DungeonGen.FreshDungeon)+      rnd = do+        modeKind <- fmap (fromMaybe $ assert `failure` smode)+                    $ opick smode (const True)+        let mode = okind modeKind+            automate p = p {playerAI = True}+            automatePS ps = ps {playersList = map automate $ playersList ps}+            players = if sautomateAll sdebug+                      then automatePS $ mplayers mode+                      else mplayers mode+        faction <- createFactions cops players+        sflavour <- dungeonFlavourMap coitem+        (sdisco, sdiscoRev) <- serverDiscos coitem+        freshDng <- DungeonGen.dungeonGen cops $ mcaves mode+        return (faction, sflavour, sdisco, sdiscoRev, freshDng)+  let (faction, sflavour, sdisco, sdiscoRev, DungeonGen.FreshDungeon{..}) =+        St.evalState rnd dungeonSeed+      defState = defStateGlobal freshDungeon freshTotalDepth+                                faction cops scoreTable+      defSer = emptyStateServer { sstart, sallTime, sheroNames, srandom+                                , srngs = RNGs (Just dungeonSeed)+                                               (Just srandom) }+  putServer defSer+  when (sbenchmark sdebug) resetGameStart+  modifyServer $ \ser -> ser {sdisco, sdiscoRev, sflavour}+  when (sdumpInitRngs sdebug) $ dumpRngs+  return $! defState++-- Spawn initial actors. Clients should notice this, to set their leaders.+populateDungeon :: (MonadAtomic m, MonadServer m) => m ()+populateDungeon = do+  cops@Kind.COps{cotile} <- getsState scops+  placeItemsInDungeon+  dungeon <- getsState sdungeon+  factionD <- getsState sfactionD+  sheroNames <- getsServer sheroNames+  let (minD, maxD) =+        case (EM.minViewWithKey dungeon, EM.maxViewWithKey dungeon) of+          (Just ((s, _), _), Just ((e, _), _)) -> (s, e)+          _ -> assert `failure` "empty dungeon" `twith` dungeon+      needInitialCrew = filter ((> 0 ) . playerInitial . gplayer . snd)+                        $ EM.assocs factionD+      getEntryLevel (_, fact) =+        max minD $ min maxD $ toEnum $ playerEntry $ gplayer fact+      arenas = ES.toList $ ES.fromList $ map getEntryLevel needInitialCrew+      initialActors lid = do+        lvl <- getLevel lid+        let arenaFactions = filter ((== lid) . getEntryLevel) needInitialCrew+            representsAlliance (fid2, fact2) =+              not $ any (\(fid3, _) -> fid3 < fid2+                                       && isAllied fact2 fid3) arenaFactions+            arenaAlliances = filter representsAlliance arenaFactions+            placeAlliance ((fid3, _), ppos) =+              mapM_ (\(fid4, fact4) ->+                      if isAllied fact4 fid3 || fid4 == fid3+                      then placeActors lid ((fid4, fact4), ppos)+                      else return ()) arenaFactions+        entryPoss <- rndToAction+                     $ findEntryPoss cops lvl (length arenaAlliances)+        mapM_ placeAlliance $ zip arenaAlliances entryPoss+      placeActors lid ((fid3, fact3), ppos) = do+        time <- getsState $ getLocalTime lid+        let nmult = 1 + fromEnum fid3 `mod` 4  -- always positive+            ntime = timeShift time (timeDeltaScale (Delta timeClip) nmult)+            validTile t = not $ Tile.hasFeature cotile F.NoActor t+        psFree <- getsState $ nearbyFreePoints validTile ppos lid+        let ps = take (playerInitial $ gplayer fact3) $ zip [0..] psFree+        forM_ ps $ \ (n, p) -> do+          go <-+            if not $ isHeroFact fact3+            then recruitActors [p] lid ntime fid3+            else do+              let hNames = fromMaybe [] $ EM.lookup fid3 sheroNames+              maid <- addHero fid3 p lid hNames (Just n) ntime+              case maid of+                Nothing -> return False+                Just aid -> do+                  mleader <- getsState $ gleader . (EM.! fid3) . sfactionD+                  when (isNothing mleader) $+                    execUpdAtomic $ UpdLeadFaction fid3 Nothing (Just aid)+                  return True+          unless go $ assert `failure` "can't spawn initial actors"+                             `twith` (lid, (fid3, fact3))+  mapM_ initialActors arenas++-- | Spawn actors of any specified faction, friendly or not.+-- To be used for initial dungeon population and for the summon effect.+recruitActors :: (MonadAtomic m, MonadServer m)+              => [Point] -> LevelId -> Time -> FactionId+              -> m Bool+recruitActors ps lid time fid = assert (not $ null ps) $ do+  Kind.COps{cofaction=Kind.Ops{okind}} <- getsState scops+  fact <- getsState $ (EM.! fid) . sfactionD+  let spawnName = fname $ okind $ gkind fact+  laid <- forM ps $ \ p ->+    if isHeroFact fact+    then addHero fid p lid [] Nothing time+    else addMonster spawnName fid p lid time+  case catMaybes laid of+    [] -> return False+    aid : _ -> do+      mleader <- getsState $ gleader . (EM.! fid) . sfactionD  -- just changed+      when (isNothing mleader) $+        execUpdAtomic $ UpdLeadFaction fid Nothing (Just aid)+      return True++-- | Create a new monster on the level, at a given position+-- and with a given actor kind and HP.+addMonster :: (MonadAtomic m, MonadServer m)+           => Text -> FactionId -> Point -> LevelId -> Time+           -> m (Maybe ActorId)+addMonster groupName bfid ppos lid time = do+  cops <- getsState scops+  fact <- getsState $ (EM.! bfid) . sfactionD+  pronoun <- if isCivilianFact cops fact+             then rndToAction $ oneOf ["he", "she"]+             else return "it"+  addActor groupName bfid ppos lid id pronoun time++-- | Create a new hero on the current level, close to the given position.+addHero :: (MonadAtomic m, MonadServer m)+        => FactionId -> Point -> LevelId -> [(Int, (Text, Text))]+        -> Maybe Int -> Time+        -> m (Maybe ActorId)+addHero bfid ppos lid heroNames mNumber time = do+  Kind.COps{cofaction=Kind.Ops{okind=okind}} <- getsState scops+  Faction{gcolor, gplayer, gkind} <- getsState $ (EM.! bfid) . sfactionD+  let fName = fname $ okind gkind+  mhs <- mapM (\n -> getsState $ \s -> tryFindHeroK s 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+      nameFromNumber 0 = ("Captain", "he")+      nameFromNumber k | k `mod` 7 == 0 = ("Heroine" <+> tshow k, "she")+      nameFromNumber k = ("Hero" <+> tshow k, "he")+      (bname, pronoun) | gcolor == Color.BrWhite =+        fromMaybe (nameFromNumber n) $ lookup n heroNames+                       | otherwise =+        let (nameN, pronounN) = nameFromNumber n+        in (playerName gplayer <+> nameN, pronounN)+      tweakBody b = b {bsymbol, bname, bcolor = gcolor}+  addActor fName 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+  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 F.NoActor t))+                [ dist ps $ factionDist `div` 2+                , dist ps $ factionDist `div` 3+                , const (Tile.hasFeature cotile F.OftenActor)+                , dist ps $ factionDist `div` 3+                , dist ps $ factionDist `div` 4+                , dist ps $ factionDist `div` 5+                , dist ps $ factionDist `div` 7+                , dist ps $ factionDist `div` 10+                ]+        nps <- tryFind (np : ps) (n - 1)+        return $! np : nps+      stairPoss = fst lstair ++ snd lstair+      middlePos = Point (lxsize `div` 2) (lysize `div` 2)+  assert (k > 0 && factionDist > 0) skip+  case k of+    1 -> tryFind stairPoss k+    2 -> -- Make sure the first faction's pos is not chosen in the middle.+         tryFind [middlePos] k+    _ | k > 2 -> tryFind [] k+    _ -> assert `failure` k++initDebug :: MonadStateRead m => Kind.COps -> DebugModeSer -> m DebugModeSer+initDebug Kind.COps{corule} sdebugSer = do+  let stdRuleset = Kind.stdRuleset corule+  return $!+    (\dbg -> dbg {sfovMode =+        sfovMode dbg `mplus` Just (rfovMode stdRuleset)}) .+    (\dbg -> dbg {ssavePrefixSer =+        ssavePrefixSer dbg `mplus` Just (rsavePrefix stdRuleset)})+    $ sdebugSer++-- | Apply debug options that don't need a new game.+applyDebug :: MonadServer m => m ()+applyDebug = do+  DebugModeSer{..} <- getsServer sdebugNxt+  modifyServer $ \ser ->+    ser {sdebugSer = (sdebugSer ser) { sniffIn+                                     , sniffOut+                                     , sallClear+                                     , sfovMode+                                     , sstopAfter+                                     , sdbgMsgSer+                                     , snewGameSer+                                     , sdumpInitRngs+                                     , sdebugCli }}
Game/LambdaHack/Server/State.hs view
@@ -13,24 +13,30 @@ import qualified System.Random as R import System.Time +import Game.LambdaHack.Atomic import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.Animation-import Game.LambdaHack.Common.AtomicCmd+import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.RuleKind+import Game.LambdaHack.Server.ItemRev  -- | Global, server state. data StateServer = StateServer   { sdisco     :: !Discovery     -- ^ full item discoveries data   , sdiscoRev  :: !DiscoRev      -- ^ reverse disco map, used for item creation+  , sdiscoAE   :: !DiscoAE       -- ^ full item aspect and effect data+  , sitemSeedD :: !ItemSeedDict  -- ^ map from item ids to item seeds   , sitemRev   :: !ItemRev       -- ^ reverse id map, used for item creation   , sflavour   :: !FlavourMap    -- ^ association of flavour to items   , sacounter  :: !ActorId       -- ^ stores next actor index   , sicounter  :: !ItemId        -- ^ stores next item index-  , sundo      :: ![Atomic]      -- ^ atomic commands performed to date+  , sprocessed :: !(EM.EnumMap LevelId Time)+                                 -- ^ actors are processed up to this time+  , sundo      :: ![CmdAtomic]   -- ^ atomic commands performed to date   , sper       :: !Pers          -- ^ perception of all factions   , srandom    :: !R.StdGen      -- ^ current random generator   , srngs      :: !RNGs          -- ^ initial random generators@@ -39,7 +45,7 @@   , sstart     :: !ClockTime     -- ^ this session start time   , sgstart    :: !ClockTime     -- ^ this game start time   , sallTime   :: !Time          -- ^ clips since the start of the session-  , sheroNames :: !(EM.EnumMap FactionId [(Int, Text)])+  , sheroNames :: !(EM.EnumMap FactionId [(Int, (Text, Text))])                                  -- ^ hero names sent by clients   , sdebugSer  :: !DebugModeSer  -- ^ current debugging mode   , sdebugNxt  :: !DebugModeSer  -- ^ debugging mode for the next game@@ -54,6 +60,7 @@   , sniffOut       :: !Bool   , sallClear      :: !Bool   , sgameMode      :: !Text+  , sautomateAll   :: !Bool   , sstopAfter     :: !(Maybe Int)   , sbenchmark     :: !Bool   , sdungeonRng    :: !(Maybe R.StdGen)@@ -87,10 +94,13 @@   StateServer     { sdisco = EM.empty     , sdiscoRev = EM.empty+    , sdiscoAE = EM.empty+    , sitemSeedD = EM.empty     , sitemRev = HM.empty     , sflavour = emptyFlavourMap     , sacounter = toEnum 0     , sicounter = toEnum 0+    , sprocessed = EM.empty     , sundo = []     , sper = EM.empty     , srandom = R.mkStdGen 42@@ -113,13 +123,14 @@                                , sniffOut = False                                , sallClear = False                                , sgameMode = "campaign"+                               , sautomateAll = False                                , sstopAfter = Nothing                                , sbenchmark = False                                , sdungeonRng = Nothing                                , smainRng = Nothing                                , sfovMode = Nothing                                , snewGameSer = False-                               , sdifficultySer = 0+                               , sdifficultySer = difficultyDefault                                , sdumpInitRngs = False                                , ssavePrefixSer = Nothing                                , sdbgMsgSer = False@@ -130,10 +141,13 @@   put StateServer{..} = do     put sdisco     put sdiscoRev+    put sdiscoAE+    put sitemSeedD     put sitemRev     put sflavour     put sacounter     put sicounter+    put sprocessed     put sundo     put (show srandom)     put srngs@@ -142,10 +156,13 @@   get = do     sdisco <- get     sdiscoRev <- get+    sdiscoAE <- get+    sitemSeedD <- get     sitemRev <- get     sflavour <- get     sacounter <- get     sicounter <- get+    sprocessed <- get     sundo <- get     g <- get     srngs <- get@@ -169,6 +186,7 @@     put sniffOut     put sallClear     put sgameMode+    put sautomateAll     put sdifficultySer     put sfovMode     put ssavePrefixSer@@ -181,6 +199,7 @@     sniffOut <- get     sallClear <- get     sgameMode <- get+    sautomateAll <- get     sdifficultySer <- get     sfovMode <- get     ssavePrefixSer <- get
− Game/LambdaHack/Utils/File.hs 
@@ -1,86 +0,0 @@--- | Saving/loading with serialization and compression.-module Game.LambdaHack.Utils.File-  ( encodeEOF, strictDecodeEOF, tryCreateDir, tryCopyDataFiles, appDataDir-  ) where--import qualified Codec.Compression.Zlib as Z-import qualified Control.Exception as Ex-import Control.Monad-import Data.Binary-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Char as Char-import System.Directory-import System.Environment-import System.FilePath-import System.IO---- | Serialize, compress and save data.--- Note that LBS.writeFile opens the file in binary mode.-encodeData :: Binary a => FilePath -> a -> IO ()-encodeData f a = do-  let tmpPath = f <.> "tmp"-  Ex.bracketOnError-    (openBinaryFile tmpPath WriteMode)-    (\h -> hClose h >> removeFile tmpPath)-    (\h -> do-       LBS.hPut h . Z.compress . encode $ a-       hClose h-       renameFile tmpPath f-    )---- | Serialize, compress and save data with an EOF marker.--- The @OK@ is used as an EOF marker to ensure any apparent problems with--- corrupted files are reported to the user ASAP.-encodeEOF :: Binary a => FilePath -> a -> IO ()-encodeEOF f a = encodeData f (a, "OK" :: String)---- | Read and decompress the serialized data.-strictReadSerialized :: FilePath -> IO LBS.ByteString-strictReadSerialized f =-  withBinaryFile f ReadMode $ \ h -> do-    c <- LBS.hGetContents h-    let d = Z.decompress c-    LBS.length d `seq` return d---- | Read, decompress and deserialize data.-strictDecodeData :: Binary a => FilePath -> IO a-strictDecodeData = fmap decode . strictReadSerialized---- | Read, decompress and deserialize data with an EOF marker.--- The @OK@ EOF marker ensures any easily detectable file corruption--- is discovered and reported before the function returns.-strictDecodeEOF :: Binary a => FilePath -> IO a-strictDecodeEOF f = do-  (a, n) <- strictDecodeData f-  if n == ("OK" :: String)-    then return $! a-    else error $ "Fatal error: corrupted file " ++ f---- | Try to create a directory, if it doesn't exist. Terminate the program--- with an exception if the directory does not exist, but can't be created.-tryCreateDir :: FilePath -> IO ()-tryCreateDir dir = do-  dirExists <- doesDirectoryExist dir-  unless dirExists $ createDirectory dir---- | Try to copy over data files, if not already there.-tryCopyDataFiles :: FilePath-                 -> (FilePath -> IO FilePath)-                 -> [(FilePath, FilePath)]-                 -> IO ()-tryCopyDataFiles dataDir pathsDataFile files =-  let cpFile (fin, fout) = do-        pathsDataIn <- pathsDataFile fin-        bIn <- doesFileExist pathsDataIn-        let pathsDataOut = dataDir </> fout-        bOut <- doesFileExist pathsDataOut-        when (not bOut && bIn) $ copyFile pathsDataIn pathsDataOut-  in mapM_ cpFile files---- | Personal data directory for the game. Depends on the OS and the game,--- e.g., for LambdaHack under Linux it's @~\/.LambdaHack\/@.-appDataDir :: IO FilePath-appDataDir = do-  progName <- getProgName-  let name = takeWhile Char.isAlphaNum progName-  getAppUserDataDirectory name
− Game/LambdaHack/Utils/Frequency.hs 
@@ -1,120 +0,0 @@-{-# LANGUAGE DeriveFoldable, DeriveTraversable #-}--- | A list of items with relative frequencies of appearance.-module Game.LambdaHack.Utils.Frequency-  ( -- * The @Frequency@ type-    Frequency-    -- * Construction-  , uniformFreq, toFreq-    -- * Transformation-  , scaleFreq, renameFreq, setFreq-    -- * Consumption-  , rollFreq, nullFreq, runFrequency, nameFrequency-  ) where--import Control.Applicative-import Control.Arrow (first, second)-import Control.Exception.Assert.Sugar-import Control.Monad-import Data.Binary-import Data.Foldable (Foldable)-import Data.Text (Text)-import Data.Traversable (Traversable)-import qualified System.Random as R--import Game.LambdaHack.Common.Msg---- TODO: do not expose runFrequency--- | The frequency distribution type.-data Frequency a = Frequency-  { nameFrequency :: !Text        -- ^ short description for debug, etc.-  , runFrequency  :: ![(Int, a)]  -- ^ give acces to raw frequency values-  }-  deriving (Show, Eq, Foldable, Traversable)--instance Monad Frequency where-  {-# INLINE return #-}-  return x = Frequency "return" [(1, x)]-  Frequency name xs >>= f =-    Frequency ("bind (" <> name <> ")")-              [(p * q, y) | (p, x) <- xs-                          , (q, y) <- runFrequency (f x) ]--instance Functor Frequency where-  fmap f (Frequency name xs) = Frequency name (map (second f) xs)--instance Applicative Frequency where-  pure  = return-  (<*>) = ap--instance MonadPlus Frequency where-  mplus (Frequency xname xs) (Frequency yname ys) =-    let name = case (xs, ys) of-          ([], []) -> "[]"-          ([], _ ) -> yname-          (_,  []) -> xname-          _ -> "(" <> xname <> ") ++ (" <> yname <> ")"-    in Frequency name (xs ++ ys)-  mzero = Frequency "[]" []--instance Alternative Frequency where-  (<|>) = mplus-  empty = mzero---- | Uniform discrete frequency distribution.-uniformFreq :: Text -> [a] -> Frequency a-uniformFreq name = Frequency name . map (\ x -> (1, x))---- | Takes a name and a list of frequencies and items--- into the frequency distribution.-toFreq :: Text -> [(Int, a)] -> Frequency a-toFreq = Frequency---- | Scale frequecy distribution, multiplying it--- by a positive integer constant.-scaleFreq :: Show a => Int -> Frequency a -> Frequency a-scaleFreq n (Frequency name xs) =-  assert (n > 0 `blame` "non-positive frequency scale" `twith` (name, n, xs)) $-  Frequency name (map (first (* n)) xs)---- | Change the description of the frequency.-renameFreq :: Text -> Frequency a -> Frequency a-renameFreq newName fr = fr {nameFrequency = newName}---- | Set frequency of an element.-setFreq :: Eq a => Frequency a -> a -> Int -> Frequency a-setFreq (Frequency name xs) x n =-  let f (_, y) | y == x = (n, x)-      f my = my-  in Frequency name $ map f xs---- | Randomly choose an item according to the distribution.-rollFreq :: Show a => Frequency a -> R.StdGen -> (a, R.StdGen)-rollFreq (Frequency name []) _ =-  assert `failure` "choice from an empty frequency" `twith` name-rollFreq (Frequency name [(n, x)]) _ | n <= 0 =-  assert `failure` "singleton void frequency" `twith` (name, n, x)-rollFreq (Frequency _ [(_, x)]) g = (x, g)  -- speedup-rollFreq (Frequency name fs) g =-  assert (sumf > 0 `blame` "frequency with nothing to pick" `twith` (name, fs))-    (frec r fs, ng)- where-  sumf = sum (map fst fs)-  (r, ng) = R.randomR (1, sumf) g-  frec :: Int -> [(Int, a)] -> a-  frec m []                     = assert `failure` "impossible roll"-                                         `twith` (name, fs, m)-  frec m ((n, x) : _)  | m <= n = x-  frec m ((n, _) : xs)          = frec (m - n) xs---- | Test if the frequency distribution is empty.-nullFreq :: Frequency a -> Bool-nullFreq (Frequency _ fs) = all (== 0) $ map fst fs--instance Binary a => Binary (Frequency a) where-  put Frequency{..} = do-    put nameFrequency-    put runFrequency-  get = do-    nameFrequency <- get-    runFrequency <- get-    return $! Frequency{..}
− Game/LambdaHack/Utils/LQueue.hs 
@@ -1,59 +0,0 @@--- | Queues implemented with two stacks to ensure fast writes.-module Game.LambdaHack.Utils.LQueue-  ( LQueue-  , newLQueue, nullLQueue, lengthLQueue, tryReadLQueue, writeLQueue-  , trimLQueue, dropStartLQueue, lastLQueue, toListLQueue-  ) where--import Data.Maybe---- | Queues implemented with two stacks.-type LQueue a = ([a], [a])  -- (read_end, write_end)---- | Create a new empty mutable queue.-newLQueue :: LQueue a-newLQueue = ([], [])---- | Check if the queue is empty.-nullLQueue :: LQueue a -> Bool-nullLQueue (rs, ws) = null rs && null ws---- | The length of the queue.-lengthLQueue :: LQueue a -> Int-lengthLQueue (rs, ws) = length rs + length ws---- | Try reading a queue. Return @Nothing@ if empty.-tryReadLQueue :: LQueue a -> Maybe (a, LQueue a)-tryReadLQueue (r : rs, ws) = Just (r, (rs, ws))-tryReadLQueue ([], []) = Nothing-tryReadLQueue ([], ws) = tryReadLQueue (reverse ws, [])---- | Write to the queue. Faster than reading.-writeLQueue :: LQueue a -> a -> LQueue a-writeLQueue (rs, ws) w = (rs, w : ws)---- | Remove all but the last written non-@Nothing@ element of the queue.-trimLQueue :: LQueue (Maybe a) -> LQueue (Maybe a)-trimLQueue (rs, ws) =-  let trim (_, w:_) = ([w], [])-      trim ([], []) = ([], [])-      trim (rsj, []) = ([last rsj], [])-  in trim (filter isJust rs, filter isJust ws)---- | Remove frames up to and including the first segment of @Nothing@ frames.--- | If the resulting queue is empty, apply trimLQueue instead.-dropStartLQueue :: LQueue (Maybe a) -> LQueue (Maybe a)-dropStartLQueue (rs, ws) =-  let dq = (dropWhile isNothing $ dropWhile isJust $ rs ++ reverse ws, [])-  in if nullLQueue dq then trimLQueue (rs, ws) else dq---- | Dump all but the last written non-@Nothing@ element of the queue, if any.-lastLQueue :: LQueue (Maybe a) -> Maybe a-lastLQueue (rs, ws) =-  let lst (_, w:_) = Just w-      lst ([], []) = Nothing-      lst (rsj, []) = Just $ last rsj-  in lst (catMaybes rs, catMaybes ws)--toListLQueue :: LQueue a -> [a]-toListLQueue (rs, ws) = rs ++ reverse ws
− Game/LambdaHack/Utils/Thread.hs 
@@ -1,29 +0,0 @@--- | Keeping track of forked threads.-module Game.LambdaHack.Utils.Thread-  ( forkChild, waitForChildren-  ) where--import Control.Concurrent (ThreadId, forkIO)-import Control.Concurrent.MVar-import Control.Exception (finally)---- Swiped from http://www.haskell.org/ghc/docs/latest/html/libraries/base/Control-Concurrent.html--forkChild :: MVar [MVar ()] -> IO () -> IO ThreadId-forkChild children io = do-  mvar <- newEmptyMVar-  childs <- takeMVar children-  putMVar children (mvar : childs)-  -- @forkFinally@ causes the program not to print client assertion failures-  -- forkFinally io (\_ -> putMVar mvar ())-  forkIO (io `finally` putMVar mvar ())--waitForChildren :: MVar [MVar ()] -> IO ()-waitForChildren children = do-  cs <- takeMVar children-  case cs of-    [] -> return ()-    m : ms -> do-      putMVar children ms-      takeMVar m-      waitForChildren children
+ GameDefinition/Client/UI/Content/KeyKind.hs view
@@ -0,0 +1,177 @@+-- | The default game key-command mapping to be used for UI. Can be overriden+-- via macros in the config file.+module Client.UI.Content.KeyKind ( standardKeys ) where++import Control.Arrow (first)++import qualified Game.LambdaHack.Client.Key as K+import Game.LambdaHack.Client.UI.Content.KeyKind+import Game.LambdaHack.Client.UI.HumanCmd+import qualified Game.LambdaHack.Common.Effect as Effect+import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Misc++standardKeys :: KeyKind+standardKeys = KeyKind+  { rhumanCommands = map (first K.mkKM)+      -- All commands are defined here, except some movement and leader picking+      -- commands. All commands are shown on help screens except debug commands+      -- and macros with empty descriptions.+      -- The order below determines the order on the help screens.+      -- Remember to put commands that show information (e.g., enter targeting+      -- mode) first.++      -- Main Menu, which apart of these includes a few extra commands+      [ ("CTRL-x", ([CmdMenu], GameExit))+      , ("CTRL-u", ([CmdMenu], GameRestart "duel"))+      , ("CTRL-k", ([CmdMenu], GameRestart "skirmish"))+      , ("CTRL-m", ([CmdMenu], GameRestart "ambush"))+      , ("CTRL-b", ([CmdMenu], GameRestart "battle"))+      , ("CTRL-a", ([CmdMenu], GameRestart "campaign"))+      , ("CTRL-d", ([CmdMenu], GameDifficultyCycle))++      -- Movement and terrain alteration+      , ("less", ([CmdMove, CmdMinimal], TriggerTile+           [ TriggerFeature { verb = "ascend"+                            , object = "a level"+                            , feature = F.Cause (Effect.Ascend 1) }+           , TriggerFeature { verb = "escape"+                            , object = "dungeon"+                            , feature = F.Cause (Effect.Escape 1) } ]))+      , ("CTRL-less", ([CmdMove], TriggerTile+           [ TriggerFeature { verb = "ascend"+                            , object = "10 levels"+                            , feature = F.Cause (Effect.Ascend 10) } ]))+      , ("greater", ([CmdMove, CmdMinimal], TriggerTile+           [ TriggerFeature { verb = "descend"+                            , object = "a level"+                            , feature = F.Cause (Effect.Ascend (-1)) }+           , TriggerFeature { verb = "escape"+                            , object = "dungeon"+                            , feature = F.Cause (Effect.Escape (-1)) } ]))+      , ("CTRL-greater", ([CmdMove], TriggerTile+           [ TriggerFeature { verb = "descend"+                            , object = "10 levels"+                            , feature = F.Cause (Effect.Ascend (-10)) } ]))+      , ("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" ]))+      , ("R", ([CmdMove], Macro "rest (wait 100 times)"+                                ["KP_Begin", "V"]))+      , ("CTRL-R", ([CmdMove], Macro "rest (wait 10 times)"+                                     ["KP_Begin", "CTRL-V"]))+      , ("c", ([CmdMove], AlterDir+           [ AlterFeature { verb = "close"+                          , object = "door"+                          , feature = F.CloseTo "vertical closed door Lit" }+           , AlterFeature { verb = "close"+                          , object = "door"+                          , feature = F.CloseTo "horizontal closed door Lit" }+           , AlterFeature { verb = "close"+                          , object = "door"+                          , feature = F.CloseTo "vertical closed door Dark" }+           , AlterFeature { verb = "close"+                          , object = "door"+                          , feature = F.CloseTo "horizontal closed door Dark" }+           ]))+      , ("period", ([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))+      , ("g", ([CmdItem, CmdMinimal],+               MoveItem [CGround] CEqp "get" "an item" True))+      , ("d", ([CmdItem], MoveItem [CEqp, CInv, CSha] CGround+                                   "drop" "an item" False))+      , ("e", ([CmdItem], MoveItem [CInv, CSha] CEqp+                                   "equip" "an item" False))+      , ("p", ([CmdItem], MoveItem [CEqp, CSha] CInv+                                   "pack" "an item into inventory backpack"+                                   False))+      , ("s", ([CmdItem], MoveItem [CEqp, CInv] CSha+                                   "stash" "and share an item" False))+      , ("a", ([CmdItem, CmdMinimal], Apply+           [ ApplyItem { verb = "activate"+                       , object = "applicable item"+                       , symbol = ' ' }+           , ApplyItem { verb = "quaff"+                       , object = "potion"+                       , symbol = '!' }+           , ApplyItem { verb = "read"+                       , object = "scroll"+                       , symbol = '?' }+           ]))+      , ("q", ([CmdItem], Apply [ApplyItem { verb = "quaff"+                                           , object = "potion"+                                           , symbol = '!' }]))+      , ("r", ([CmdItem], Apply [ApplyItem { verb = "read"+                                           , object = "scroll"+                                           , symbol = '?' }]))+      , ("f", ([CmdItem, CmdMinimal], Project+           [ApplyItem { verb = "fling"+                      , object = "projectable item"+                      , symbol = ' ' }]))+      , ("t", ([CmdItem], Project [ApplyItem { verb = "throw"+                                             , object = "missile"+                                             , symbol = '|' }]))+      , ("z", ([CmdItem], Project [ApplyItem { verb = "zap"+                                             , object = "wand"+                                             , symbol = '/' }]))++      -- Targeting+      , ("KP_Multiply", ([CmdTgt, CmdMinimal], TgtEnemy))+      , ("backslash", ([CmdTgt], Macro "" ["KP_Multiply"]))+      , ("slash", ([CmdTgt], TgtFloor))+      , ("plus", ([CmdTgt], EpsIncr True))+      , ("minus", ([CmdTgt], EpsIncr False))+      , ("BackSpace", ([CmdTgt], TgtClear))+      , ("CTRL-question", ([CmdTgt], TgtUnknown))+      , ("CTRL-I", ([CmdTgt], TgtItem))+      , ("CTRL-braceleft", ([CmdTgt], TgtStair True))+      , ("CTRL-braceright", ([CmdTgt], TgtStair False))++      -- Automation+      , ("equal", ([CmdAuto], SelectActor))+      , ("underscore", ([CmdAuto], SelectNone))+      , ("v", ([CmdAuto], Repeat 1))+      , ("V", ([CmdAuto], Repeat 100))+      , ("CTRL-v", ([CmdAuto], Repeat 1000))+      , ("CTRL-V", ([CmdAuto], Repeat 10))+      , ("apostrophe", ([CmdAuto], Record))+      , ("CTRL-A", ([CmdAuto], Automate))++      -- Assorted+      , ("question", ([CmdMeta], Help))+      , ("D", ([CmdMeta], History))+      , ("T", ([CmdMeta], MarkSuspect))+      , ("Z", ([CmdMeta], MarkVision))+      , ("C", ([CmdMeta], MarkSmell))+      , ("Tab", ([CmdMeta], MemberCycle))+      , ("ISO_Left_Tab", ([CmdMeta], MemberBack))+      , ("space", ([CmdMeta], Clear))+      , ("Escape", ([CmdMeta, CmdMinimal], Cancel))+      , ("Return", ([CmdMeta], Accept))++      -- Debug and others not to display in help screens+      , ("CTRL-s", ([CmdDebug], GameSave))+      , ("CTRL-f", ([CmdDebug], GameRestart "safari"))+      , ("CTRL-e", ([CmdDebug], GameRestart "defense"))+      ]+  }
− GameDefinition/Content/ActorKind.hs 
@@ -1,88 +0,0 @@--- | Monsters and heroes for LambdaHack.-module Content.ActorKind ( cdefs ) where--import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.ContentDef-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ActorKind--cdefs :: ContentDef ActorKind-cdefs = ContentDef-  { getSymbol = asymbol-  , getName = aname-  , getFreq = afreq-  , validate = validateActorKind-  , content =-      [hero, projectile, eye, fastEye, nose]-  }-hero,        projectile, eye, fastEye, nose :: ActorKind--hero = ActorKind-  { asymbol = '@'-  , aname   = "hero"-  , afreq   = [("hero", 1)]-  , acolor  = BrWhite  -- modified if many hero factions-  , ahp     = rollDice 50 1-  , aspeed  = toSpeed 2-  , asight  = True-  , asmell  = False-  , aiq     = 15  -- higher that that leads to looping movement-  , aregen  = 500-  , acanDo  = [minBound..maxBound]-  }--projectile = ActorKind  -- includes homing missiles-  { asymbol = '*'-  , aname   = "projectile"-  , afreq   = [("projectile", 1)]  -- Does not appear randomly in the dungeon.-  , acolor  = BrWhite-  , ahp     = rollDice 0 0-  , aspeed  = toSpeed 0-  , asight  = False-  , asmell  = False-  , aiq     = 0-  , aregen  = maxBound-  , acanDo  = [Track]-  }--eye = ActorKind-  { asymbol = 'e'-  , aname   = "reducible eye"-  , afreq   = [("monster", 60), ("horror", 60)]-  , acolor  = BrRed-  , ahp     = rollDice 7 4-  , aspeed  = toSpeed 2-  , asight  = True-  , asmell  = False-  , aiq     = 8-  , aregen  = 100-  , acanDo  = [minBound..maxBound]-  }-fastEye = ActorKind-  { asymbol = 'e'-  , aname   = "super-fast eye"-  , afreq   = [("monster", 15), ("horror", 15)]-  , acolor  = BrBlue-  , ahp     = rollDice 1 6-  , aspeed  = toSpeed 4-  , asight  = True-  , asmell  = False-  , aiq     = 12-  , aregen  = 10  -- Regenerates fast (at max HP most of the time!).-  , acanDo  = [minBound..maxBound]-  }-nose = ActorKind-  { asymbol = 'n'-  , aname   = "point-free nose"-  , afreq   = [("monster", 20), ("horror", 20)]-  , acolor  = Green-  , ahp     = rollDice 17 2-  , aspeed  = toSpeed 1.8-  , asight  = False-  , asmell  = True-  , aiq     = 0-  , aregen  = 100-  , acanDo  = [minBound..maxBound]-  }
GameDefinition/Content/CaveKind.hs view
@@ -4,8 +4,8 @@ import Data.Ratio  import Game.LambdaHack.Common.ContentDef+import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Random as Random import Game.LambdaHack.Content.CaveKind  cdefs :: ContentDef CaveKind@@ -15,30 +15,32 @@   , getFreq = cfreq   , validate = validateCaveKind   , content =-      [rogue, arena, empty, noise, combat, battle]+      [rogue, arena, empty, noise, battle, skirmish, ambush, safari1, safari2, safari3]   }-rogue,        arena, empty, noise, combat, battle :: CaveKind+rogue,        arena, empty, noise, battle, skirmish, ambush, safari1, safari2, safari3 :: CaveKind  rogue = CaveKind-  { csymbol       = '$'+  { csymbol       = 'R'   , cname         = "A maze of twisty passages"   , cfreq         = [("dng", 100), ("caveRogue", 1)]   , cxsize        = fst normalLevelBound + 1   , cysize        = snd normalLevelBound + 1-  , cgrid         = rollDiceXY [(3, 2)] [(1, 2), (2, 1)]-  , cminPlaceSize = rollDiceXY [(2, 2), (2, 1)] [(4, 1)]-  , cmaxPlaceSize = rollDiceXY [(fst normalLevelBound, 1)]-                               [(snd normalLevelBound, 1)]-  , cdarkChance   = rollDeep (1, 54) (0, 0)-  , cnightChance  = intToDeep 100+  , cgrid         = DiceXY (3 * d 2) (d 2 + 2)+  , cminPlaceSize = DiceXY (2 * d 2 + 2) 4+  , cmaxPlaceSize = DiceXY 15 10+  , cdarkChance   = d 54 + dl 20+  , cnightChance  = 51   , cauxConnects  = 1%3   , cmaxVoid      = 1%6   , cminStairDist = 30   , cdoorChance   = 1%2   , copenChance   = 1%10   , chidden       = 8-  , citemNum      = rollDice 7 2-  , citemFreq     = [(70, "useful"), (30, "treasure")]+  , cactorFreq    = [("monster", 50), ("animal", 50)]+  , citemNum      = 10 * d 2+  , citemFreq     = [("useful", 70), ("treasure", 30)]+  , cplaceFreq    = [("rogue", 100)]+  , cpassable     = False   , cdefTile        = "fillerWall"   , cdarkCorTile    = "floorCorridorDark"   , clitCorTile     = "floorCorridorLit"@@ -51,73 +53,122 @@   { csymbol       = 'A'   , cname         = "Underground city"   , cfreq         = [("dng", 30), ("caveArena", 1)]-  , cgrid         = rollDiceXY [(2, 2)] [(2, 2)]-  , cminPlaceSize = rollDiceXY [(2, 2), (3, 1)] [(4, 1)]-  , cdarkChance   = rollDeep (1, 80) (1, 60)-  , cnightChance  = intToDeep 0+  , cgrid         = DiceXY (2 * d 2) (2 * d 2)+  , cminPlaceSize = DiceXY (2 * d 2 + 3) 4+  , cdarkChance   = d 80 + dl 60+  , cnightChance  = 0   , cmaxVoid      = 1%3   , chidden       = 1000-  , citemNum      = rollDice 5 2  -- few rooms+  , cactorFreq    = [("monster", 70), ("animal", 30)]+  , citemNum      = 8 * d 2  -- few rooms+  , cpassable     = True   , cdefTile      = "arenaSet"-  , cdarkCorTile  = "trailLit"  -- let paths around rooms be lit+  , cdarkCorTile  = "trailLit"  -- let trails give off light   , clitCorTile   = "trailLit"   } empty = rogue-  { csymbol       = '.'+  { csymbol       = 'E'   , cname         = "Tall cavern"   , cfreq         = [("dng", 20), ("caveEmpty", 1)]-  , cgrid         = rollDiceXY [(1, 2), (1, 1)] [(1, 1)]-  , cminPlaceSize = rollDiceXY [(10, 1)] [(10, 1)]-  , cmaxPlaceSize = rollDiceXY [(fst normalLevelBound * 3 `div` 5, 1)]-                               [(snd normalLevelBound * 3 `div` 5, 1)]-  , cdarkChance   = rollDeep (1, 80) (1, 80)-  , cnightChance  = intToDeep 0+  , cgrid         = DiceXY (d 2 + 1) 1+  , cminPlaceSize = DiceXY 10 10+  , cmaxPlaceSize = DiceXY 24 12+  , cdarkChance   = d 80 + dl 80+  , cnightChance  = 0   , cauxConnects  = 1   , cmaxVoid      = 1%2   , cminStairDist = 50   , chidden       = 1000-  , citemNum      = rollDice 8 2  -- whole floor strewn with treasure+  , cactorFreq    = [("monster", 10), ("animal", 90)]+  , citemNum      = 6 * d 2  -- few rooms+  , cpassable     = True   , cdefTile      = "emptySet"-  , cdarkCorTile  = "trailLit"  -- let paths around rooms be lit+  , cdarkCorTile  = "floorArenaDark"   , clitCorTile   = "floorArenaLit"   } noise = rogue-  { csymbol       = '!'+  { csymbol       = 'N'   , cname         = "Glittering cave"-  , cfreq         = [("dng", 20), ("caveNoise", 1)]-  , cgrid         = rollDiceXY [(2, 2)] [(1, 2), (1, 1)]-  , cminPlaceSize = rollDiceXY [(3, 2), (2, 1)] [(5, 1)]-  , cdarkChance   = rollDeep (1, 80) (1, 40)-  , cnightChance  = rollDeep (1, 40) (1, 40)+  , cfreq         = [("dng", 10), ("caveNoise", 1)]+  , cgrid         = DiceXY 3 3+  , cminPlaceSize = DiceXY 8 4+  , cmaxPlaceSize = DiceXY 24 12+  , cnightChance  = d 100+  , cauxConnects  = 0   , cmaxVoid      = 0   , chidden       = 1000-  , citemNum      = rollDice 4 2  -- fewer rooms+  , cactorFreq    = [("monster", 80), ("animal", 20)]+  , citemNum      = 12 * d 2  -- an incentive to explore the labyrinth+  , cpassable     = True+  , cplaceFreq    = [("noise", 50), ("rogue", 50)]   , cdefTile      = "noiseSet"+  , cdarkCorTile  = "floorArenaDark"+  , clitCorTile   = "floorArenaLit"+  }+battle = rogue  -- few lights and many solids, to help the less numerous heroes+  { csymbol       = 'B'+  , cname         = "Old battle ground"+  , cfreq         = [("caveBattle", 1)]+  , cgrid         = DiceXY (2 * d 2 + 1) 3+  , cminPlaceSize = DiceXY 3 3+  , cmaxPlaceSize = DiceXY 9 7+  , cdarkChance   = 0+  , cnightChance  = 100+  , cdoorChance   = 2%10+  , copenChance   = 9%10+  , chidden       = 1000+  , cactorFreq    = []+  , citemNum      = 12 * d 2+  , citemFreq     = [("useful", 100)]+  , cplaceFreq    = [("battle", 50), ("rogue", 50)]+  , cpassable     = True+  , cdefTile      = "battleSet"   , cdarkCorTile  = "trailLit"  -- let trails give off light   , clitCorTile   = "trailLit"   }-combat = rogue-  { csymbol       = 'C'-  , cname         = "Combat arena"-  , cfreq         = [("caveCombat", 1)]-  , cgrid         = rollDiceXY [(2, 2), (3, 1)] [(1, 2), (2, 1)]-  , cminPlaceSize = rollDiceXY [(3, 1)] [(3, 1)]-  , cmaxPlaceSize = rollDiceXY [(5, 1)] [(5, 1)]-  , cdarkChance   = intToDeep 100-  , cnightChance  = rollDeep (1, 67) (0, 0)-  , chidden       = 1000-  , cauxConnects  = 0+skirmish = rogue  -- many random solid tiles, to break LOS, since it's a day+  { csymbol       = 'S'+  , cname         = "Sunny woodland"+  , cfreq         = [("caveSkirmish", 1)]+  , cgrid         = DiceXY (2 * d 2 + 2) (d 2 + 2)+  , cminPlaceSize = DiceXY 3 3+  , cmaxPlaceSize = DiceXY 7 5+  , cdarkChance   = 100+  , cnightChance  = 0   , cdoorChance   = 1   , copenChance   = 0-  , citemNum      = rollDice 12 2-  , citemFreq     = [(100, "useful")]-  , cdefTile      = "combatSet"-  , cdarkCorTile  = "trailLit"  -- let trails give off light+  , chidden       = 1000+  , cactorFreq    = []+  , citemNum      = 12 * d 2+  , citemFreq     = [("useful", 100)]+  , cplaceFreq    = [("skirmish", 60), ("rogue", 40)]+  , cpassable     = True+  , cdefTile      = "skirmishSet"+  , cdarkCorTile  = "floorArenaLit"   , clitCorTile   = "floorArenaLit"   }-battle = combat  -- TODO: actors can get stuck forever among trees-  { csymbol       = 'B'-  , cname         = "Battle arena"-  , cfreq         = [("caveBattle", 1)]-  , cdefTile      = "battleSet"+ambush = rogue  -- lots of lights, to give a chance to snipe+  { csymbol       = 'M'+  , cname         = "Public garden at night"+  , cfreq         = [("caveAmbush", 1)]+  , cgrid         = DiceXY (2 * d 2 + 3) (d 2 + 2)+  , cminPlaceSize = DiceXY 3 3+  , cmaxPlaceSize = DiceXY 5 5+  , cdarkChance   = 0+  , cnightChance  = 100+  , cauxConnects  = 1+  , cdoorChance   = 1%10+  , copenChance   = 9%10+  , chidden       = 1000+  , cactorFreq    = []+  , citemNum      = 12 * d 2+  , citemFreq     = [("useful", 100)]+  , cplaceFreq    = [("ambush", 100)]+  , cpassable     = True+  , cdefTile      = "ambushSet"+  , cdarkCorTile  = "trailLit"  -- let trails give off light+  , clitCorTile   = "trailLit"   }+safari1 = ambush {cfreq = [("caveSafari1", 1)]}+safari2 = battle {cfreq = [("caveSafari2", 1)]}+safari3 = skirmish {cfreq = [("caveSafari3", 1)]}
GameDefinition/Content/FactionKind.hs view
@@ -2,6 +2,8 @@ -- for LambdaHack. module Content.FactionKind ( cdefs ) where +import qualified Data.EnumMap.Strict as EM+ import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.ContentDef import Game.LambdaHack.Content.FactionKind@@ -13,43 +15,59 @@   , getFreq = ffreq   , validate = validateFactionKind   , content =-      [hero, monster, horror]+      [hero, civilian, monster, animal, horror]   }-hero,        monster, horror :: FactionKind+hero,        civilian, monster, animal, horror :: FactionKind  hero = FactionKind-  { fsymbol        = '@'-  , fname          = "hero"-  , ffreq          = [("hero", 1)]-  , fAbilityLeader = allAbilities-  , fAbilityOther  = meleeAdjacent+  { fsymbol       = '1'+  , fname         = "hero"+  , ffreq         = [("hero", 1)]+  , fSkillsLeader = allSkills+  , fSkillsOther  = meleeAdjacent   } +civilian = FactionKind+  { fsymbol       = '@'+  , fname         = "civilian"+  , ffreq         = [("civilian", 1)]+  , fSkillsLeader = allSkills+  , fSkillsOther  = allSkills  -- not coordinated by any leadership+  }+ monster = FactionKind-  { fsymbol        = 'm'-  , fname          = "monster"-  , ffreq          = [("monster", 1), ("summon", 50)]-  , fAbilityLeader = allAbilities-  , fAbilityOther  = allAbilities+  { fsymbol       = 'm'+  , fname         = "monster"+  , ffreq         = [("monster", 1)]+  , fSkillsLeader = allSkills+  , fSkillsOther  = allSkills   } +animal = FactionKind+  { fsymbol       = 'd'+  , fname         = "animal"+  , ffreq         = [("animal", 1)]+  , fSkillsLeader = animalSkills+  , fSkillsOther  = animalSkills+  }+ horror = FactionKind-  { fsymbol        = 'h'-  , fname          = "horror"-  , ffreq          = [("horror", 1), ("summon", 50)]-  , fAbilityLeader = allAbilities-  , fAbilityOther  = allAbilities+  { fsymbol       = 'h'+  , fname         = "horror"+  , ffreq         = [("horror", 1)]+  , fSkillsLeader = allSkills+  , fSkillsOther  = allSkills   }  -_noAbility, _onlyFollowTrack, meleeAdjacent, _meleeAndRanged, allAbilities :: [Ability]--_noAbility = []  -- not even projectiles will fly+meleeAdjacent, _meleeAndRanged, animalSkills, allSkills :: Skills -_onlyFollowTrack = [Track]  -- projectiles enabled+meleeAdjacent = EM.fromList $ zip [AbWait, AbMelee] [1, 1..] -meleeAdjacent = [Track, Melee]+-- Melee and reaction fire.+_meleeAndRanged = EM.fromList $ zip [AbWait, AbMelee, AbProject] [1, 1..] -_meleeAndRanged = [Track, Melee, Ranged]  -- melee and reaction fire+animalSkills =+  EM.fromList $ zip [AbMove, AbMelee, AbAlter, AbWait, AbTrigger] [1, 1..] -allAbilities = [minBound..maxBound]+allSkills = unitSkills
GameDefinition/Content/ItemKind.hs view
@@ -1,12 +1,17 @@--- | Weapons and treasure for LambdaHack.+-- | Weapon and treasure definitions. module Content.ItemKind ( cdefs ) where +import Data.List++import Content.ItemKindActor+import Content.ItemKindOrgan+import Content.ItemKindShrapnel import Game.LambdaHack.Common.Color import Game.LambdaHack.Common.ContentDef+import Game.LambdaHack.Common.Dice import Game.LambdaHack.Common.Effect import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.ItemFeature-import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Content.ItemKind  cdefs :: ContentDef ItemKind@@ -15,253 +20,676 @@   , getName = iname   , getFreq = ifreq   , validate = validateItemKind-  , content =-      [amulet, dart, gem1, gem2, gem3, currency, harpoon, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand1, wand2, fist, foot, tentacle, fragrance, mist_healing, mist_wounding, glass_piece, smoke]+  , content = items ++ organs ++ shrapnels ++ actors   }-amulet,        dart, gem1, gem2, gem3, currency, harpoon, potion1, potion2, potion3, ring, scroll1, scroll2, scroll3, sword, wand1, wand2, fist, foot, tentacle, fragrance, mist_healing, mist_wounding, glass_piece, smoke :: ItemKind -gem, potion, scroll, wand :: ItemKind  -- generic templates+items :: [ItemKind]+items =+  [bolas, brassLantern, buckler, dart, dart200, gem1, gem2, gem3, gloveFencing, gloveGauntlet, gloveJousting, currency, gorget, harpoon, jumpingPole, monocle, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, net, oilLamp, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, potion10, ring1, ring2, ring3, ring4, ring5, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, shield, dagger, hammer, sword, halberd, wand1, wand2, woodenTorch, armorLeather, armorMail, whetstone] --- castDeep (aDb, xDy) = castDice aDb + (lvl - 1) * castDice xDy / (depth - 1)+bolas,    brassLantern, buckler, dart, dart200, gem1, gem2, gem3, gloveFencing, gloveGauntlet, gloveJousting, currency, gorget, harpoon, jumpingPole, monocle, necklace1, necklace2, necklace3, necklace4, necklace5, necklace6, necklace7, net, oilLamp, potion1, potion2, potion3, potion4, potion5, potion6, potion7, potion8, potion9, potion10, ring1, ring2, ring3, ring4, ring5, scroll1, scroll2, scroll3, scroll4, scroll5, scroll6, scroll7, scroll8, scroll9, shield, dagger, hammer, sword, halberd, wand1, wand2, woodenTorch, armorLeather, armorMail, whetstone :: ItemKind -amulet = ItemKind-  { isymbol  = '"'-  , iname    = "amulet"-  , ifreq    = [("useful", 6)]-  , iflavour = zipFancy [BrGreen]-  , icount   = intToDeep 1-  , iverbApply   = "tear down"-  , iverbProject = "cast"-  , iweight  = 30-  , itoThrow = -50  -- not dense enough-  , ifeature = [Cause $ Regeneration (rollDeep (2, 3) (1, 10))]-  }+gem, necklace, potion, ring, scroll, wand :: ItemKind  -- generic templates++-- * Thrown weapons+ dart = ItemKind   { isymbol  = '|'   , iname    = "dart"-  , ifreq    = [("useful", 20)]+  , ifreq    = [("useful", 100), ("any arrow", 100)]   , iflavour = zipPlain [Cyan]-  , icount   = rollDeep (3, 3) (0, 0)-  , iverbApply   = "snap"-  , iverbProject = "hurl"+  , icount   = 3 * d 3+  , irarity  = [(1, 20)]+  , iverbHit = "prick"   , iweight  = 50-  , itoThrow = 0  -- a cheap dart-  , ifeature = [Cause $ Hurt (rollDice 1 2) (rollDeep (1, 2) (1, 2))]+  , iaspects = [AddHurtRanged ((d 6 + dl 6) |*| 10)]+  , ieffects = [Hurt (3 * d 1)]+  , ifeature = []+  , 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     = []   }+dart200 = ItemKind+  { isymbol  = '|'+  , iname    = "fine dart"+  , ifreq    = [("useful", 100), ("any arrow", 50)]  -- TODO: until arrows added+  , iflavour = zipPlain [BrRed]+  , icount   = 3 * d 3+  , irarity  = [(4, 20)]+  , iverbHit = "prick"+  , iweight  = 50+  , iaspects = [AddHurtRanged ((d 6 + dl 6) |*| 10)]+  , ieffects = [Hurt (2 * d 1)]+  , ifeature = [toVelocity 200]+  , idesc    = "Finely balanced for throws of great speed."+  , ikit     = []+  }++-- * Exotic thrown weapons++bolas = ItemKind+  { isymbol  = '|'+  , iname    = "bolas set"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [BrYellow]+  , icount   = dl 4+  , irarity  = [(5, 5), (10, 5)]+  , iverbHit = "entangle"+  , iweight  = 500+  , iaspects = []+  , ieffects = [Hurt (2 * d 1), Paralyze (5 + d 5), ActivateInv '!']+  , ifeature = []+  , idesc    = "Wood balls tied with hemp rope for tripping, entangling and bringing down crashing."+  , ikit     = []+  }+harpoon = ItemKind+  { isymbol  = '|'+  , iname    = "harpoon"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [Brown]+  , icount   = dl 5+  , irarity  = [(5, 5), (10, 20)]+  , iverbHit = "hook"+  , iweight  = 4000+  , iaspects = [AddHurtRanged ((d 2 + 2 * dl 5) |*| 10)]+  , 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."+  , ikit     = []+  }+net = ItemKind+  { isymbol  = '|'+  , iname    = "net"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [White]+  , icount   = dl 3+  , irarity  = [(3, 5), (10, 4)]+  , iverbHit = "entangle"+  , iweight  = 1000+  , iaspects = []+  , ieffects = [ Paralyze (5 + d 5)+               , DropBestWeapon, DropEqp ']' False ]+  , ifeature = []+  , idesc    = "A wide net with weights along the edges. Entangles weapon and armor alike."+  , ikit     = []+  }++-- * Lights++woodenTorch = ItemKind+  { isymbol  = '('+  , iname    = "wooden torch"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [Brown]+  , icount   = 1+  , irarity  = [(1, 10)]+  , iverbHit = "scorch"+  , iweight  = 1200+  , iaspects = [ AddLight 3+               , AddSight (-2) ]  -- not only flashes, but also sparks+  , ieffects = [Burn 3]+  , ifeature = [EqpSlot EqpSlotAddLight "", Identified]+  , idesc    = "A smoking, heavy wooden torch, burning in an unsteady fire."+  , ikit     = []+  }+oilLamp = ItemKind+  { isymbol  = '('+  , iname    = "oil lamp"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 1+  , irarity  = [(5, 4), (10, 4)]+  , iverbHit = "burn"+  , iweight  = 1000+  , iaspects = [AddLight 3, AddSight (-1)]+  , ieffects = [Burn 3, Paralyze 3, OnSmash (Explode "burning oil 3")]+  , ifeature = [ toVelocity 70  -- hard not to spill the oil while throwing+               , Fragile, EqpSlot EqpSlotAddLight "", Identified ]+  , idesc    = "A clay lamp filled with plant oil feeding a tiny wick."+  , ikit     = []+  }+brassLantern = ItemKind+  { isymbol  = '('+  , iname    = "brass lantern"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [BrWhite]+  , icount   = 1+  , irarity  = [(10, 3)]+  , iverbHit = "burn"+  , iweight  = 2400+  , iaspects = [AddLight 4, AddSight (-1)]+  , ieffects = [Burn 4, Paralyze 4, OnSmash (Explode "burning oil 4")]+  , ifeature = [ toVelocity 70  -- hard to throw so that it opens and burns+               , Fragile, EqpSlot EqpSlotAddLight "", Identified ]+  , idesc    = "Very bright and very heavy brass lantern."+  , ikit     = []+  }++-- * Treasure+ gem = ItemKind   { isymbol  = '*'   , iname    = "gem"-  , ifreq    = [("treasure", 20)]  -- x3, but rare on shallow levels-  , iflavour = zipPlain brightCol  -- natural, so not fancy-  , icount   = intToDeep 0-  , iverbApply   = "crush"-  , iverbProject = "toss"+  , ifreq    = [("treasure", 100)]  -- x3, but rare on shallow levels+  , iflavour = zipPlain $ delete BrYellow brightCol  -- natural, so not fancy+  , icount   = 1+  , irarity  = []+  , iverbHit = "tap"   , iweight  = 50-  , itoThrow = 0-  , ifeature = []+  , iaspects = [AddLight 1, AddSpeed (-1)]  -- reflects strongly, distracts+  , ieffects = []+  , ifeature = [ Durable  -- prevent destruction by evil monsters+               , Precious ]+  , idesc    = "Useless, and still worth around 100 gold each. Would gems of thought and pearls of artful design be valued that much in our age of Science and Progress!"+  , ikit     = []   } gem1 = gem-  { icount   = rollDeep (0, 0) (1, 1)  -- appears on max depth+  { irarity  = [(2, 0), (10, 10)]   } gem2 = gem-  { icount   = rollDeep (0, 0) (1, 2)  -- appears halfway+  { irarity  = [(5, 0), (10, 10)]   } gem3 = gem-  { icount   = rollDeep (0, 0) (1, 3)  -- appears early+  { irarity  = [(8, 0), (10, 10)]   } currency = ItemKind   { isymbol  = '$'   , iname    = "gold piece"-  , ifreq    = [("treasure", 20), ("currency", 1)]+  , ifreq    = [("treasure", 100), ("currency", 1)]   , iflavour = zipPlain [BrYellow]-  , icount   = rollDeep (0, 0) (10, 10)  -- appears on lvl 2-  , iverbApply   = "grind"-  , iverbProject = "toss"+  , icount   = 10 + d 20 + dl 20+  , irarity  = [(1, 0), (5, 20), (10, 10)]+  , iverbHit = "tap"   , iweight  = 31-  , itoThrow = 0-  , ifeature = []+  , iaspects = []+  , ieffects = []+  , ifeature = [Durable, Identified, Precious]+  , idesc    = "Reliably valuable in every civilized plane of existence."+  , ikit     = []   }-harpoon = ItemKind-  { isymbol  = '|'-  , iname    = "harpoon"-  , ifreq    = [("useful", 25)]-  , iflavour = zipPlain [Brown]-  , icount   = rollDeep (0, 0) (2, 2)-  , iverbApply   = "break up"-  , iverbProject = "hurl"-  , iweight  = 4000-  , itoThrow = 0  -- cheap but deadly-  , ifeature = [Cause $ Hurt (rollDice 2 2) (rollDeep (1, 2) (2, 2))]++-- * Periodic jewelry++gorget = ItemKind+  { isymbol  = '"'+  , iname    = "gorget"+  , ifreq    = [("useful", 100)]+  , iflavour = zipFancy [BrCyan]+  , irarity  = [(4, 1), (10, 2)]+  , icount   = 1+  , iverbHit = "whip"+  , iweight  = 30+  , iaspects = [Periodic $ d 4 + dl 4, AddArmorMelee 1, AddArmorRanged 1]+  , ieffects = [RefillCalm 1]+  , ifeature = [ 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     = []   }+necklace = ItemKind+  { isymbol  = '"'+  , iname    = "necklace"+  , ifreq    = [("useful", 100)]+  , iflavour = zipFancy stdCol ++ zipPlain brightCol+  , irarity  = [(4, 2), (10, 5)]+  , icount   = 1+  , iverbHit = "whip"+  , iweight  = 30+  , iaspects = []+  , ieffects = []+  , ifeature = [ Precious, EqpSlot EqpSlotPeriodic ""+               , toVelocity 50 ]  -- not dense enough+  , idesc    = "Menacing Greek symbols shimmer with increasing speeds along a chain of fine encrusted links. After a tense build-up, a prismatic arc shoots towards the ground and the iridescence subdues, becomes ordered and resembles a harmless ornament again, for a time."+  , ikit     = []+  }+necklace1 = necklace+  { iaspects = [Periodic $ d 2 + dl 2]+  , ieffects = [RefillHP 1]+  , idesc    = "A cord of dried herbs and healing berries."+  }+necklace2 = necklace+  { irarity  = [(2, 0), (10, 1)]+  , iaspects = [Periodic $ d 4 + dl 2]+  , ieffects = [ Impress+               , Summon [("summonable animal", 1)] $ 1 + dl 2, Explode "waste" ]+  }+necklace3 = necklace+  { iaspects = [Periodic $ d 4 + dl 2]+  , ieffects = [Paralyze $ 5 + d 5 + dl 5, RefillCalm 999]+  }+necklace4 = necklace+  { iaspects = [Periodic $ 2 * d 10 + dl 10]+  , ieffects = [Teleport $ 2 + d 3]+  }+necklace5 = necklace+  { iaspects = [Periodic $ d 4 + dl 2]+  , ieffects = [Teleport $ 10 + d 10]+  }+necklace6 = necklace+  { iaspects = [Periodic $ 2 * d 5 + dl 5]+  , ieffects = [PushActor (ThrowMod 100 50)]+  }+necklace7 = necklace+  { irarity  = [(4, 0), (10, 2)]+  , iaspects = [Periodic $ 2 * d 5 + dl 15]+  , ieffects = [InsertMove 1, RefillHP (-1)]+  , ifeature = ifeature necklace ++ [Durable]+      -- evil players would throw before death, to destroy+      -- TODO: teach AI to wear only for fight; prevent players from meleeing+      -- allies with that (Durable)+  }++-- * Non-periodic jewelry++monocle = ItemKind+  { isymbol  = '='+  , iname    = "monocle"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [White]+  , icount   = 1+  , irarity  = [(6, 0), (10, 1)]+  , iverbHit = "rap"+  , iweight  = 50+  , iaspects = [AddSight $ dl 3]+  , ieffects = []+  , ifeature = [Precious, Identified, Durable, EqpSlot EqpSlotAddSight ""]+  , idesc    = "Let's you better focus your weaker eye."+  , ikit     = []+  }+ring = ItemKind+  { isymbol  = '='+  , iname    = "ring"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain stdCol ++ zipFancy darkCol+  , icount   = 1+  , irarity  = [(6, 2), (10, 5)]+  , iverbHit = "knock"+  , iweight  = 15+  , iaspects = []+  , ieffects = []+  , ifeature = [Precious, Identified]+  , idesc    = "It looks like an ordinary object, but it's in fact a generator of exceptional effects: adding to some of your natural abilities and subtracting from others. You'd profit enormously if you could find a way to multiply such generators..."  -- TODO: merge rings: do not add effects though, because it would make the ring too powerful (only one eqp slot taken); define correct, but not overpowered multiplication, if possible+  , ikit     = []+  }+ring1 = ring+  { irarity  = [(2, 0), (10, 2)]+  , iaspects = [AddSpeed 1, AddMaxHP $ dl 3 - 5 - d 3]+  , ifeature = ifeature ring ++ [Durable, EqpSlot EqpSlotAddSpeed ""]+  }+ring2 = ring+  { iaspects = [AddMaxHP $ 3 + dl 5, AddMaxCalm $ dl 6 - 15 - d 6]+  , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddMaxHP ""]+  }+ring3 = ring+  { iaspects = [AddMaxCalm $ 10 + dl 10]+  , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddMaxCalm ""]+  , idesc    = "Cold, solid to the touch, perfectly round, engraved with solemn, strangely comforting, worn out words."+  }+ring4 = ring  -- TODO: move to level-ups and to timed effects+  { irarity  = [(3, 8), (10, 12)]+  , iaspects = [AddHurtMelee $ 3 * d 4 + dl 15, AddMaxHP $ dl 3 - 4 - d 2]+  , ifeature = ifeature ring ++ [Durable, EqpSlot EqpSlotAddHurtMelee ""]+  }+ring5 = ring  -- by the time it's found, probably no space in eqp+  { irarity  = [(5, 0), (10, 1)]+  , iaspects = [AddLight $ d 2]+  , ifeature = ifeature ring ++ [EqpSlot EqpSlotAddLight ""]+  , idesc    = "A sturdy ring with a large, shining stone."+  }++-- * Exploding consumables, often intended to be thrown+ potion = ItemKind   { isymbol  = '!'   , iname    = "potion"-  , ifreq    = [("useful", 15)]-  , iflavour = zipFancy stdCol-  , icount   = intToDeep 1-  , iverbApply   = "gulp down"-  , iverbProject = "lob"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain stdCol ++ zipFancy brightCol+  , icount   = 1+  , irarity  = [(1, 10), (10, 8)]+  , iverbHit = "splash"   , iweight  = 200-  , itoThrow = -50  -- oily, bad grip-  , ifeature = []+  , iaspects = []+  , ieffects = []+  , ifeature = [ toVelocity 50  -- oily, bad grip+               , Applicable, Fragile ]+  , idesc    = "A flask of bubbly, slightly oily liquid of a suspect color."  -- purely natural; no maths, no magic  -- TODO: move distortion to a special flask item or when some precious magical item is destroyed (jewelry?)?+  , ikit     = []   } potion1 = potion-  { ifreq    = [("useful", 5)]-  , ifeature = [Cause ApplyPerfume, Explode "fragrance"]+  { ieffects = [ NoEffect "of rose water", Impress+               , OnSmash (ApplyPerfume), OnSmash (Explode "fragrance") ]   } potion2 = potion-  { ifeature = [Cause $ Heal 5, Explode "mist healing"]+  { ifreq    = [("useful", 1)]  -- extremely rare+  , irarity  = [(10, 1)]+  , ieffects = [ NoEffect "of musky concoction", Impress, DropBestWeapon+               , OnSmash (Explode "pheromone")]   } potion3 = potion-  { ifreq    = [("useful", 5)]-  , ifeature = [Cause $ Heal (-5), Explode "mist wounding"]+  { ieffects = [RefillHP 5, OnSmash (Explode "healing mist")]   }-ring = ItemKind-  { isymbol  = '='-  , iname    = "ring"-  , ifreq    = []  -- [("useful", 10)]  -- TODO: make it useful-  , iflavour = zipPlain [White]-  , icount   = intToDeep 1-  , iverbApply   = "squeeze down"-  , iverbProject = "toss"-  , iweight  = 15-  , itoThrow = 0-  , ifeature = [Cause $ Searching (rollDeep (1, 6) (3, 2))]+potion4 = potion  -- TODO: a bit boring+  { irarity  = [(1, 5)]+  , ieffects = [RefillHP (-5), OnSmash (Explode "wounding mist")]   }+potion5 = potion+  { ieffects = [ Explode "explosion blast 10", Impress+               , PushActor (ThrowMod 200 75)+               , OnSmash (Explode "explosion blast 10") ]+  }+potion6 = potion+  { irarity  = [(10, 2)]+  , ieffects = [ NoEffect "of distortion"+               , OnSmash (Explode "distortion")]+  }+potion7 = potion+  { ieffects = [ NoEffect "of bait cocktail", Impress+               , OnSmash (Summon [("summonable animal", 1)] $ 1 + dl 2)+               , OnSmash (Explode "waste") ]+  }+potion8 = potion+  { ieffects = [ OneOf [Impress, DropBestWeapon, RefillHP 5, Burn 3]+               , OnSmash (OneOf [ Explode "healing mist"+                                , Explode "wounding mist"+                                , Explode "fragrance"+                                , Explode "explosion blast 10" ]) ]+  }+potion9 = potion+  { irarity  = [(4, 1), (10, 2)]+  , ieffects = [ OneOf [ Dominate, DropBestWeapon, RefillHP 15, Burn 9+                       , InsertMove 2]+               , OnSmash (OneOf [ Explode "healing mist"+                                , Explode "healing mist"+                                , Explode "pheromone"+                                , Explode "distortion"+                                , Explode "explosion blast 20" ]) ]+  }+potion10 = potion+  { ifreq    = [("useful", 100), ("potion of glue", 1)]+  , irarity  = [(1, 1)]+  , icount   = 1 + d 2+  , ieffects = [ NoEffect "of glue", Paralyze (5 + d 5)+               , OnSmash (Explode "glue")]+  }++-- * Non-exploding consumables, not specifically designed for throwing+ scroll = ItemKind   { isymbol  = '?'   , iname    = "scroll"-  , ifreq    = [("useful", 4)]-  , iflavour = zipFancy darkCol  -- arcane and old-  , icount   = intToDeep 1-  , iverbApply   = "decipher"-  , iverbProject = "lob"+  , ifreq    = [("useful", 100), ("any scroll", 100)]+  , iflavour = zipFancy stdCol ++ zipPlain darkCol  -- arcane and old+  , icount   = 1+  , irarity  = [(1, 10), (10, 7)]+  , iverbHit = "thump"   , iweight  = 50-  , itoThrow = -75  -- bad shape, even rolled up-  , ifeature = []+  , iaspects = []+  , ieffects = []+  , ifeature = [ toVelocity 25  -- bad shape, even rolled up+               , Applicable ]+  , idesc    = "Scraps of haphazardly scribbled mysteries from beyond. Is this equation an alchemical recipe? Is this diagram an extradimensional map? Is this formula a secret call sign?"+  , ikit     = []   } scroll1 = scroll-  { ifreq    = [("useful", 2)]-  , ifeature = [Cause $ CallFriend 1]+  { irarity  = [(10, 2)]+  , ieffects = [CallFriend 1]   } scroll2 = scroll-  { ifeature = [Cause $ Summon 1]+  { irarity  = [(1, 5), (10, 3)]+  , ieffects = [NoEffect "of fireworks", Explode "firecracker 7"]   } scroll3 = scroll-  { ifeature = [Cause $ Ascend (-1)]+  { irarity  = [(1, 4), (10, 2)]+  , ieffects = [Ascend (-1)]   }+scroll4 = scroll+  { ieffects = [ OneOf [ Teleport $ 2 + d 5, RefillCalm 10, RefillCalm (-10)+                       , InsertMove 4, Paralyze 10, Identify CGround ] ]+  }+scroll5 = scroll+  { irarity  = [(1, 4), (10, 6)]+  , ieffects = [ OneOf [ Summon standardSummon $ d 2+                       , CallFriend 1, Ascend (-1), Ascend 1+                       , RefillCalm 30, RefillCalm (-30), CreateItem $ d 2+                       , PolyItem CGround ] ]+               -- TODO: ask player: Escape 1+  }+scroll6 = scroll+  { ieffects = [Teleport $ 2 + d 5]+  }+scroll7 = scroll+  { irarity  = [(10, 2)]+  , ieffects = [InsertMove $ d 2 + dl 2]+  }+scroll8 = scroll+  { irarity  = [(3, 6), (10, 3)]+  , ieffects = [Identify CGround]  -- TODO: ask player: AskPlayer cstore eff?+  }+scroll9 = scroll+  { irarity  = [(3, 3), (10, 9)]+  , ieffects = [PolyItem CGround]+  }++standardSummon :: Freqs+standardSummon = [("monster", 30), ("summonable animal", 70)]++-- * Armor++armorLeather = ItemKind+  { isymbol  = '['+  , iname    = "leather armor"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [Brown]+  , icount   = 1+  , irarity  = [(4, 9)]+  , iverbHit = "thud"+  , iweight  = 7000+  , iaspects = [ AddHurtMelee (-3)+               , AddArmorMelee $ (1 + dl 3) |*| 5+               , AddArmorRanged $ (1 + dl 3) |*| 5 ]+  , ieffects = []+  , ifeature = [ toVelocity 30  -- unwieldy to throw and blunt+               , Durable, EqpSlot EqpSlotAddArmorMelee "", Identified ]+  , idesc    = "A stiff jacket formed from leather boiled in bee wax. Smells much better than the rest of your garment."+  , ikit     = []+  }+armorMail = armorLeather+  { iname    = "mail armor"+  , iflavour = zipPlain [Cyan]+  , irarity  = [(7, 9)]+  , iweight  = 12000+  , iaspects = [ AddHurtMelee (-3)+               , AddArmorMelee $ (2 + dl 3) |*| 5+               , AddArmorRanged $ (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+  { isymbol  = '['+  , iname    = "leather gauntlet"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 1+  , irarity  = [(4, 6), (10, 12)]+  , iverbHit = "flap"+  , iweight  = 100+  , iaspects = [ AddHurtMelee $ 2 * (d 3 + 2 * dl 5)+               , AddArmorRanged $ d 2 + dl 2 ]+  , ieffects = []+  , ifeature = [ toVelocity 30  -- flaps and flutters+               , Durable, EqpSlot EqpSlotAddArmorRanged "", Identified ]+  , idesc    = "A fencing glove from rough leather ensuring a good grip. Also quite effective in deflecting or even catching slow projectiles."+  , ikit     = []+  }+gloveGauntlet = gloveFencing+  { iname    = "steel gauntlet"+  , irarity  = [(6, 12)]+  , iflavour = zipPlain [BrCyan]+  , iweight  = 300+  , iaspects = [ AddArmorMelee $ 2 * (d 2 + dl 2)+               , AddArmorRanged $ 2 * (d 2 + dl 2) ]+  , idesc    = "Long leather gauntlet covered in overlapping steel plates."+  }+gloveJousting = gloveFencing+  { iname    = "jousting gauntlet"+  , irarity  = [(6, 6)]+  , iflavour = zipFancy [BrRed]+  , iweight  = 500+  , iaspects = [ AddHurtMelee $ - 10 - d 5 + dl 5+               , AddArmorMelee $ 2 * (d 2 + dl 3)+               , AddArmorRanged $ 2 * (d 2 + dl 3) ]+  , idesc    = "Rigid, steel, jousting handgear. If only you had a lance. And a horse."+  }+-- Shield doesn't protect against ranged attacks to prevent+-- micromanagement: walking with shield, melee without.+buckler = ItemKind+  { isymbol  = '['+  , iname    = "buckler"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [Blue]+  , icount   = 1+  , irarity  = [(4, 7)]+  , iverbHit = "bash"+  , iweight  = 2000+  , iaspects = [AddArmorMelee 40, AddHurtMelee (-30)]+  , ieffects = []+  , ifeature = [ toVelocity 30  -- unwieldy to throw and blunt+               , 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, 7)]+  , iflavour = zipPlain [Green]+  , iweight  = 3000+  , iaspects = [AddArmorMelee 80, AddHurtMelee (-70)]+  , ifeature = [ toVelocity 20  -- unwieldy to throw and blunt+               , Durable, EqpSlot EqpSlotAddArmorMelee "", Identified ]+  , idesc    = "Large and unwieldy. Absorbs a percentage of melee damage, both dealt and sustained. Too heavy to intercept projectiles with."+  }++-- * Weapons++dagger = ItemKind+  { isymbol  = ')'+  , iname    = "dagger"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [BrCyan]+  , icount   = 1+  , irarity  = [(1, 20), (10, 4)]+  , iverbHit = "stab"+  , iweight  = 1000+  , iaspects = [AddHurtMelee $ 2 * (d 3 + 2 * dl 5), AddArmorMelee $ d 4 + dl 4]+  , ieffects = [Hurt (4 * d 1)]+  , ifeature = [ toVelocity 40  -- ensuring it hits with the tip costs speed+               , Durable, EqpSlot EqpSlotWeapon "", Identified ]+  , idesc    = "A short dagger for thrusting and parrying blows. Does not penetrate deeply, but is hard to block. Especially useful in conjunction with a larger weapon."+  , ikit     = []+  }+hammer = ItemKind+  { isymbol  = ')'+  , iname    = "war hammer"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [BrMagenta]+  , icount   = 1+  , irarity  = [(4, 12), (10, 2)]+  , iverbHit = "club"+  , iweight  = 1500+  , iaspects = [AddHurtMelee $ d 3 + 2 * dl 5]+  , ieffects = [Hurt (6 * d 1)]+  , ifeature = [ toVelocity 20  -- ensuring it hits with the sharp tip costs+               , Durable, EqpSlot EqpSlotWeapon "", Identified ]+  , idesc    = "It may not cause grave wounds, but neither does it glance off nor ricochet. Great sidearm for opportunistic blows against armored foes."+  , ikit     = []+  } sword = ItemKind   { isymbol  = ')'   , iname    = "sword"-  , ifreq    = [("useful", 40)]-  , iflavour = zipPlain [BrCyan]-  , icount   = intToDeep 1-  , iverbApply   = "hit"-  , iverbProject = "heave"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [BrBlue]+  , icount   = 1+  , irarity  = [(3, 1), (6, 20), (10, 10)]+  , iverbHit = "slash"   , iweight  = 2000-  , itoThrow = -50  -- ensuring it hits with the tip costs speed-  , ifeature = [Cause $ Hurt (rollDice 5 1) (rollDeep (1, 2) (4, 2))]+  , iaspects = []+  , ieffects = [Hurt (9 * d 1)]+  , ifeature = [ toVelocity 20  -- 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     = []   }+halberd = ItemKind+  { isymbol  = ')'+  , iname    = "halberd"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 1+  , irarity  = [(7, 1), (10, 10)]+  , iverbHit = "impale"+  , iweight  = 3000+  , iaspects = [AddArmorMelee $ 2 * (d 4 + dl 4)]+  , ieffects = [Hurt (12 * d 1)]+  , ifeature = [ toVelocity 20  -- not balanced+               , Durable, EqpSlot EqpSlotWeapon "", Identified ]+  , idesc    = "Versatile, with great reach and leverage. Foes are held at a distance."+  , ikit     = []+  }++-- * Wands+ wand = ItemKind   { isymbol  = '/'   , iname    = "wand"-  , ifreq    = [("useful", 5)]+  , ifreq    = [("useful", 100)]   , iflavour = zipFancy brightCol-  , icount   = intToDeep 1-  , iverbApply   = "snap"-  , iverbProject = "zap"+  , icount   = 1+  , irarity  = []  -- TODO: add charges, etc.+  , iverbHit = "club"   , iweight  = 300-  , itoThrow = 25  -- magic-  , ifeature = [Fragile]+  , iaspects = [AddLight 1, AddSpeed (-1)]  -- pulsing with power, distracts+  , ieffects = []+  , ifeature = [ toVelocity 125  -- magic+               , Applicable, Durable ]+  , idesc    = "Buzzing with dazzling light that shines even through appendages that handle it."  -- TODO: add math flavour+  , ikit     = []   } wand1 = wand-  { ifeature = ifeature wand ++ [Cause Dominate]+  { ieffects = []  -- TODO: emit a cone of sound shrapnel that makes enemy cover his ears and so drop '|' and '{'   } wand2 = wand-  { ifreq    = [("useful", 2)]-  , ifeature = ifeature wand ++ [Cause $ Heal (-25)]-  }-fist = sword-  { isymbol  = '@'-  , iname    = "fist"-  , ifreq    = [("hth", 1), ("unarmed", 100)]-  , iverbApply   = "punch"-  , iverbProject = "ERROR, please report: iverbProject fist"-  , ifeature = [Cause $ Hurt (rollDice 5 1) (intToDeep 0)]-  }-foot = sword-  { isymbol  = '@'-  , iname    = "foot"-  , ifreq    = [("hth", 1), ("unarmed", 50)]-  , iverbApply   = "kick"-  , iverbProject = "ERROR, please report: iverbProject foot"-  , ifeature = [Cause $ Hurt (rollDice 5 1) (intToDeep 0)]-  }-tentacle = sword-  { isymbol  = 'S'-  , iname    = "tentacle"-  , ifreq    = [("hth", 1), ("monstrous", 100)]-  , iverbApply   = "hit"-  , iverbProject = "ERROR, please report: iverbProject tentacle"-  , ifeature = [Cause $ Hurt (rollDice 5 1) (intToDeep 0)]-  }-fragrance = ItemKind-  { isymbol  = '\''-  , iname    = "fragrance"-  , ifreq    = [("fragrance", 1)]-  , iflavour = zipFancy [BrMagenta]-  , icount   = rollDeep (5, 2) (0, 0)-  , iverbApply   = "smell"-  , iverbProject = "exude"-  , iweight  = 1-  , itoThrow = -93  -- the slowest that gets anywhere (1 step only)-  , ifeature = [Fragile]-  }-mist_healing = ItemKind-  { isymbol  = '\''-  , iname    = "mist"-  , ifreq    = [("mist healing", 1)]-  , iflavour = zipFancy [White]-  , icount   = rollDeep (12, 2) (0, 0)-  , iverbApply   = "inhale"-  , iverbProject = "blow"-  , iweight  = 1-  , itoThrow = -87  -- the slowest that travels at least 2 steps-  , ifeature = [Cause $ Heal 1, Fragile]-  }-mist_wounding = ItemKind-  { isymbol  = '\''-  , iname    = "mist"-  , ifreq    = [("mist wounding", 1)]-  , iflavour = zipFancy [White]-  , icount   = rollDeep (12, 2) (0, 0)-  , iverbApply   = "inhale"-  , iverbProject = "blow"-  , iweight  = 1-  , itoThrow = -87-  , ifeature = [Cause $ Heal (-1), Fragile]+  { ieffects = []   }-glass_piece = ItemKind-  { isymbol  = '\''-  , iname    = "glass piece"-  , ifreq    = [("glass piece", 1)]-  , iflavour = zipPlain [BrBlue]-  , icount   = rollDeep (10, 2) (0, 0)-  , iverbApply   = "grate"-  , iverbProject = "toss"-  , iweight  = 10-  , itoThrow = 0-  , ifeature = [Cause $ Hurt (rollDice 1 1) (intToDeep 0), Fragile, Linger 20]++-- * Assorted tools++jumpingPole = ItemKind+  { isymbol  = '('+  , iname    = "jumping pole"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [White]+  , icount   = 1+  , irarity  = [(1, 4), (10, 2)]+  , iverbHit = "prod"+  , iweight  = 10000+  , iaspects = []+  , ieffects = [InsertMove 2]  -- TODO: implement with timed speed instead+                               -- and then make Durable, freq 2, and just trade+                               -- taken turn now for a free turn later+  , ifeature = [Applicable, Identified]+  , idesc    = "Makes you vulnerable at take-off, but then you are free like a bird."+  , ikit     = []   }-smoke = ItemKind-  { isymbol  = '\''-  , iname    = "smoke"-  , ifreq    = [("smoke", 1)]-  , iflavour = zipPlain [BrBlack]-  , icount   = rollDeep (12, 2) (0, 0)-  , iverbApply   = "inhale"-  , iverbProject = "blow"-  , iweight  = 1-  , itoThrow = -70-  , ifeature = [Fragile]+whetstone = ItemKind+  { isymbol  = '~'+  , iname    = "whetstone"+  , ifreq    = [("useful", 100)]+  , iflavour = zipPlain [Blue]+  , icount   = 1+  , irarity  = [(5, 5)]+  , iverbHit = "smack"+  , iweight  = 400+  , iaspects = [AddHurtMelee $ 2 * (d 3 + 2 * dl 5)]+  , ieffects = []+  , ifeature = [EqpSlot EqpSlotAddHurtMelee "", Identified]+  , 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     = []   }
+ GameDefinition/Content/ItemKindActor.hs view
@@ -0,0 +1,279 @@+-- | Actor (or rather actor body trunk) definitions.+module Content.ItemKindActor ( actors ) where++import qualified Data.EnumMap.Strict as EM++import Game.LambdaHack.Common.Ability+import Game.LambdaHack.Common.Color+import Game.LambdaHack.Common.Effect+import Game.LambdaHack.Common.Flavour+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Content.ItemKind++actors :: [ItemKind]+actors =+  [warrior, adventurer, blacksmith, forester, scientist, clerk, hairdresser, lawyer, peddler, taxCollector, eye, fastEye, nose, elbow, armadillo, gilaMonster, komodoDragon, hyena, alligator, hornetSwarm, thornbush, geyser]++warrior,    adventurer, blacksmith, forester, scientist, clerk, hairdresser, lawyer, peddler, taxCollector, eye, fastEye, nose, elbow, armadillo, gilaMonster, komodoDragon, hyena, alligator, hornetSwarm, thornbush, geyser :: ItemKind++-- * Hunams++warrior = ItemKind+  { isymbol  = '@'+  , iname    = "warrior"  -- modified if in hero faction+  , ifreq    = [("hero", 100), ("civilian", 100)]+  , iflavour = zipPlain [BrBlack]  -- modified if in hero faction+  , icount   = 1+  , irarity  = [(1, 5)]+  , iverbHit = "thud"+  , iweight  = 80000+  , iaspects = [ AddMaxHP 50, AddMaxCalm 60, AddSpeed 20+               , AddSight 3 ]  -- no via eyes, but feel, hearing, etc.+  , ieffects = []+  , ifeature = [Durable, Identified]+  , idesc    = ""+  , ikit     = [("fist", COrgan), ("foot", COrgan), ("eye 4", COrgan)]+  }+adventurer = warrior+  { iname    = "adventurer" }+blacksmith = warrior+  { iname    = "blacksmith" }+forester = warrior+  { iname    = "forester" }+scientist = warrior+  { iname    = "scientist" }++clerk = warrior+  { iname    = "clerk"+  , ifreq    = [("civilian", 100)] }+hairdresser = clerk+  { iname    = "hairdresser" }+lawyer = clerk+  { iname    = "lawyer" }+peddler = clerk+  { iname    = "peddler" }+taxCollector = clerk+  { iname    = "tax collector" }++-- * Monsters++eye = ItemKind+  { isymbol  = 'e'+  , iname    = "reducible eye"+  , ifreq    = [("monster", 100), ("horror", 100)]+  , iflavour = zipPlain [BrRed]+  , icount   = 1+  , irarity  = [(1, 10), (10, 6)]+  , iverbHit = "thud"+  , iweight  = 80000+  , iaspects = [ AddMaxHP 20, AddMaxCalm 60, AddSpeed 20+               , AddSight 4 ]  -- can shoot for as long as lives+  , 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)]+  }+fastEye = ItemKind+  { isymbol  = 'j'+  , iname    = "injective jaw"+  , ifreq    = [("monster", 100), ("horror", 100)]+  , iflavour = zipPlain [BrBlue]+  , icount   = 1+  , irarity  = [(10, 5)]+  , iverbHit = "thud"+  , iweight  = 80000+  , iaspects = [ AddMaxHP 6, AddMaxCalm 60, AddSpeed 30+               , AddSight 7 ]  -- can shoot for as long as lives+  , 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) ]+  }+nose = ItemKind+  { isymbol  = 'n'+  , iname    = "point-free nose"+  , ifreq    = [("monster", 100), ("horror", 100)]+  , iflavour = zipPlain [BrGreen]+  , icount   = 1+  , irarity  = [(1, 6), (10, 4)]+  , iverbHit = "thud"+  , iweight  = 80000+  , iaspects = [ AddMaxHP 40, AddMaxCalm 30, AddSpeed 18+               , AddSmell 3 ]  -- depends solely on smell+  , 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)]+  }+elbow = ItemKind+  { isymbol  = 'e'+  , iname    = "commutative elbow"+  , ifreq    = [("monster", 100), ("horror", 100)]+  , iflavour = zipPlain [BrMagenta]+  , icount   = 1+  , irarity  = [(6, 1), (10, 5)]+  , iverbHit = "thud"+  , iweight  = 80000+  , iaspects = [ AddMaxHP 10, AddMaxCalm 80, AddSpeed 26+               , AddSkills $ EM.singleton AbMelee (-1)+               , AddSight 15 ]  -- can shoot for as long as lives+  , 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)+               , ("any arrow", CInv), ("any arrow", CInv)+               , ("any arrow", CInv), ("any arrow", CInv) ]+  }+-- "ground x" --- for immovable monster that can only tele or prob travel+-- forgetful+-- pullback+-- skeletal++-- * Animals++armadillo = ItemKind+  { isymbol  = 'a'+  , iname    = "giant armadillo"+  , ifreq    = [("animal", 100), ("horror", 100), ("summonable animal", 100)]+  , iflavour = zipPlain [Brown]+  , icount   = 1+  , irarity  = [(1, 5)]+  , iverbHit = "thud"+  , iweight  = 80000+  , iaspects = [ AddMaxHP 30, AddMaxCalm 30, AddSpeed 18+               , AddSkills $ EM.singleton AbAlter (-1)+               , AddSight 3 ]+  , ieffects = []+  , ifeature = [Durable, Identified]+  , idesc    = ""+  , ikit     = [ ("claw", COrgan), ("snout", COrgan), ("armored skin", COrgan)+               , ("nostril", COrgan) ]+  }+gilaMonster = ItemKind+  { isymbol  = 'g'+  , iname    = "Gila monster"+  , ifreq    = [("animal", 100), ("horror", 100), ("summonable animal", 100)]+  , iflavour = zipPlain [Magenta]+  , icount   = 1+  , irarity  = [(2, 5), (10, 3)]+  , iverbHit = "thud"+  , iweight  = 80000+  , iaspects = [ AddMaxHP 15, AddMaxCalm 60, AddSpeed 15+               , AddSkills $ EM.singleton AbAlter (-1)+               , AddSight 3 ]+  , ieffects = []+  , ifeature = [Durable, Identified]+  , idesc    = ""+  , ikit     = [ ("venom tooth", COrgan), ("small claw", COrgan)+               , ("eye 4", COrgan), ("nostril", COrgan) ]+  }+komodoDragon = ItemKind  -- bad hearing+  { isymbol  = 'k'+  , iname    = "Komodo dragon"+  , ifreq    = [("animal", 100), ("horror", 100), ("summonable animal", 100)]+  , iflavour = zipPlain [Blue]+  , icount   = 1+  , irarity  = [(5, 5), (10, 7)]+  , iverbHit = "thud"+  , iweight  = 80000+  , iaspects = [ AddMaxHP 40, AddMaxCalm 60, AddSpeed 18+               , AddSight 3 ]+  , ieffects = []+  , ifeature = [Durable, Identified]+  , idesc    = ""+  , ikit     = [ ("large tail", COrgan), ("jaw", COrgan), ("small claw", COrgan)+               , ("speed gland 4", COrgan), ("armored skin", COrgan)+               , ("eye 2", COrgan), ("nostril", COrgan) ]+  }+hyena = ItemKind+  { isymbol  = 'h'+  , iname    = "spotted hyena"+  , ifreq    = [("animal", 100), ("horror", 100), ("summonable animal", 100)]+  , iflavour = zipPlain [Red]+  , icount   = 1+  , irarity  = [(4, 6), (10, 6)]+  , iverbHit = "thud"+  , iweight  = 80000+  , iaspects = [ AddMaxHP 30, AddMaxCalm 60, AddSpeed 35+               , AddSight 3 ]+  , ieffects = []+  , ifeature = [Durable, Identified]+  , idesc    = ""+  , ikit     = [("jaw", COrgan), ("eye 4", COrgan), ("nostril", COrgan)]+  }+alligator = ItemKind+  { isymbol  = 'a'+  , iname    = "alligator"+  , ifreq    = [("animal", 100), ("horror", 100), ("summonable animal", 100)]+  , iflavour = zipPlain [Blue]+  , icount   = 1+  , irarity  = [(10, 8)]+  , iverbHit = "thud"+  , iweight  = 80000+  , iaspects = [ AddMaxHP 30, AddMaxCalm 60, AddSpeed 17+               , AddArmorMelee 30, AddArmorRanged 30+               , AddSight 3 ]+  , ieffects = []+  , ifeature = [Durable, Identified]+  , idesc    = ""+  , ikit     = [ ("large jaw", COrgan), ("large tail", COrgan), ("claw", COrgan)+               , ("armored skin", COrgan), ("eye 4", COrgan) ]+  }++-- * Non-animal animals++hornetSwarm = ItemKind+  { isymbol  = 'h'+  , iname    = "hornet swarm"+  , ifreq    = [("animal", 100), ("horror", 100), ("summonable animal", 100)]+  , iflavour = zipPlain [Magenta]+  , icount   = 1+  , irarity  = [(5, 1), (10, 5)]+  , iverbHit = "thud"+  , iweight  = 1000+  , iaspects = [ AddMaxHP 5, AddMaxCalm 60, AddSpeed 30, AddSight 2+               , AddSkills $ EM.singleton AbAlter (-1)+               , AddArmorMelee 90, AddArmorRanged 90 ]+  , ieffects = []+  , ifeature = [Durable, Identified]+  , idesc    = ""+  , ikit     = [("sting", COrgan)]+  }+thornbush = ItemKind+  { isymbol  = 'b'+  , iname    = "thornbush"+  , ifreq    = [("animal", 100)]+  , iflavour = zipPlain [Brown]+  , icount   = 1+  , irarity  = [(3, 2), (10, 1)]+  , iverbHit = "thud"+  , iweight  = 80000+  , iaspects = [ AddMaxHP 30, AddMaxCalm 999, AddSpeed 20+               , AddSkills+                 $ EM.fromDistinctAscList (zip [minBound..maxBound] [-1, -1..])+                   `addSkills` EM.fromList (zip [AbWait, AbMelee] [1, 1..])+               , AddArmorMelee 50, AddArmorRanged 50 ]+  , ieffects = []+  , ifeature = [Durable, Identified]+  , idesc    = ""+  , ikit     = [("thorn", COrgan)]+  }+geyser = ItemKind+  { isymbol  = 'g'+  , iname    = "geyser"+  , ifreq    = [("animal", 100)]+  , iflavour = zipPlain [White]+  , icount   = 1+  , irarity  = [(5, 2), (10, 1)]+  , iverbHit = "thud"+  , iweight  = 80000+  , iaspects = [ AddMaxHP 100, AddMaxCalm 999, AddSpeed 5+               , AddSkills+                 $ EM.fromDistinctAscList (zip [minBound..maxBound] [-1, -1..])+                   `addSkills` EM.fromList (zip [AbWait, AbMelee] [1, 1..]) ]+  , ieffects = []+  , ifeature = [Durable, Identified]+  , idesc    = ""+  , ikit     = [("vent", COrgan), ("fissure", COrgan)]+  }
+ GameDefinition/Content/ItemKindOrgan.hs view
@@ -0,0 +1,259 @@+-- | Organ definitions.+module Content.ItemKindOrgan ( organs ) where++import Game.LambdaHack.Common.Color+import Game.LambdaHack.Common.Dice+import Game.LambdaHack.Common.Effect+import Game.LambdaHack.Common.Flavour+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Content.ItemKind++organs :: [ItemKind]+organs =+  [fist, foot, tentacle, lash, noseTip, lip, claw, smallClaw, snout, sting, venomTooth, venomFang, largeTail, jaw, largeJaw, tooth, pupil, armoredSkin, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, eye2, eye3, eye4, eye5, nostril, thorn, vent, fissure]++fist,    foot, tentacle, lash, noseTip, lip, claw, smallClaw, snout, sting, venomTooth, venomFang, largeTail, jaw, largeJaw, tooth, pupil, armoredSkin, speedGland2, speedGland4, speedGland6, speedGland8, speedGland10, eye2, eye3, eye4, eye5, nostril, thorn, vent, fissure :: ItemKind++-- * Parameterized organs++speedGland :: Int -> ItemKind+speedGland n = fist+  { iname    = "speed gland"+  , ifreq    = [("speed gland" <+> tshow n, 100)]+  , icount   = 1+  , iverbHit = "spit at"+  , iaspects = [AddSpeed $ intToDice n, Periodic $ intToDice n]+  , ieffects = [RefillHP 1]+  , ifeature = [Durable, Identified]+  , idesc    = ""+  }+speedGland2 = speedGland 2+speedGland4 = speedGland 4+speedGland6 = speedGland 6+speedGland8 = speedGland 8+speedGland10 = speedGland 10+eye :: Int -> ItemKind+eye n = fist+  { iname    = "eye"+  , ifreq    = [("eye" <+> tshow n, 100)]+  , icount   = 2+  , iverbHit = "glare at"+  , iaspects = [AddSight (intToDice n)]+  , ieffects = []+  , ifeature = [Durable, Identified]+  , idesc    = ""+  }+eye2 = eye 2+eye3 = eye 3+eye4 = eye 4+eye5 = eye 5++-- * Human weapon organs++fist = ItemKind+  { isymbol  = '%'+  , iname    = "fist"+  , ifreq    = [("fist", 100)]+  , iflavour = zipPlain [BrRed]+  , icount   = 2+  , irarity  = [(1, 1)]+  , iverbHit = "punch"+  , iweight  = 2000+  , iaspects = []+  , ieffects = [Hurt (4 * d 1)]+  , ifeature = [Durable, EqpSlot EqpSlotWeapon "", Identified]+  , idesc    = ""+  , ikit     = []+  }+foot = fist+  { iname    = "foot"+  , ifreq    = [("foot", 50)]+  , icount   = 2+  , iverbHit = "kick"+  , ieffects = [Hurt (4 * d 1)]+  , idesc    = ""+  }++-- * Universal weapon organs++claw = fist+  { iname    = "claw"+  , ifreq    = [("claw", 50)]+  , icount   = 2  -- even if more, only the fore claws used for fighting+  , iverbHit = "slash"+  , ieffects = [Hurt (6 * d 1)]+  , idesc    = ""+  }+smallClaw = fist+  { iname    = "small claw"+  , ifreq    = [("small claw", 50)]+  , icount   = 2+  , iverbHit = "slash"+  , ieffects = [Hurt (3 * d 1)]+  , idesc    = ""+  }+snout = fist+  { iname    = "snout"+  , ifreq    = [("snout", 10)]+  , iverbHit = "bite"+  , ieffects = [Hurt (2 * d 1)]+  , idesc    = ""+  }+jaw = fist+  { iname    = "jaw"+  , ifreq    = [("jaw", 20)]+  , icount   = 1+  , iverbHit = "rip"+  , ieffects = [Hurt (5 * d 1)]+  , idesc    = ""+  }+largeJaw = fist+  { iname    = "large jaw"+  , ifreq    = [("large jaw", 100)]+  , icount   = 1+  , iverbHit = "crush"+  , ieffects = [Hurt (12 * d 1)]+  , idesc    = ""+  }+tooth = fist+  { iname    = "tooth"+  , ifreq    = [("tooth", 20)]+  , icount   = 3+  , iverbHit = "nail"+  , ieffects = [Hurt (3 * d 1)]+  , idesc    = ""+  }++-- * Monster weapon organs++tentacle = fist+  { iname    = "tentacle"+  , ifreq    = [("tentacle", 50)]+  , icount   = 4+  , iverbHit = "slap"+  , ieffects = [Hurt (4 * d 1)]+  , idesc    = ""+  }+lash = fist+  { iname    = "lash"+  , ifreq    = [("lash", 100)]+  , icount   = 1+  , iverbHit = "lash"+  , ieffects = [Hurt (4 * d 1)]+  , idesc    = ""+  }+noseTip = fist+  { iname    = "tip"+  , ifreq    = [("nose tip", 50)]+  , icount   = 1+  , iverbHit = "poke"+  , ieffects = [Hurt (2 * d 1)]+  , idesc    = ""+  }+lip = fist+  { iname    = "lip"+  , ifreq    = [("lip", 10)]+  , icount   = 2+  , iverbHit = "lap"+  , ieffects = [Hurt (2 * d 1)]  -- TODO: decrease Hurt, but use+  , idesc    = ""+  }++-- * Special weapon organs++thorn = fist+  { iname    = "thorn"+  , ifreq    = [("thorn", 100)]+  , icount   = 7+  , iverbHit = "impale"+  , ieffects = [Hurt (2 * d 1)]+  , idesc    = ""+  }+fissure = fist+  { iname    = "fissure"+  , ifreq    = [("fissure", 100)]+  , icount   = 2+  , iverbHit = "hiss at"+  , ieffects = [Burn 1]+  , idesc    = ""+  }+sting = fist+  { iname    = "sting"+  , ifreq    = [("sting", 100)]+  , icount   = 1+  , iverbHit = "sting"+  , ieffects = [Burn 1, Paralyze 2]+  , idesc    = ""+  }+venomTooth = fist+  { iname    = "venom tooth"+  , ifreq    = [("venom tooth", 100)]+  , icount   = 2+  , iverbHit = "bite"+  , ieffects = [Hurt (3 * d 1), Paralyze 3]+  , idesc    = ""+  }+venomFang = fist+  { iname    = "venom fang"+  , ifreq    = [("venom fang", 100)]+  , icount   = 2+  , iverbHit = "bite"+  , ieffects = [Hurt (3 * d 1)]  -- TODO: +12 damage or poison effect+  , idesc    = ""+  }+largeTail = fist+  { iname    = "large tail"+  , ifreq    = [("large tail", 50)]+  , icount   = 1+  , iverbHit = "knock"+  , ieffects = [Hurt (8 * d 1), PushActor (ThrowMod 400 25)]+  , idesc    = ""+  }+pupil = fist+  { iname    = "pupil"+  , ifreq    = [("pupil", 100)]+  , icount   = 1+  , iverbHit = "gaze at"+  , iaspects = [AddSight 7]+  , ieffects = [Hurt (4 * d 1), Paralyze 1]  -- TODO: decrease Hurt, but use+  , idesc    = ""+  }++-- * Armor organs++armoredSkin = fist+  { iname    = "armored skin"+  , ifreq    = [("armored skin", 100)]+  , icount   = 1+  , iverbHit = "bash"+  , iaspects = [AddArmorMelee 33, AddArmorRanged 33]+  , ieffects = []+  , ifeature = [Durable, Identified]+  , idesc    = ""+  }++-- * Sense organs++nostril = fist+  { iname    = "nostril"+  , ifreq    = [("nostril", 100)]+  , icount   = 2+  , iverbHit = "snuff"+  , iaspects = [AddSmell 1]+  , ieffects = []+  , ifeature = [Durable, Identified]+  , idesc    = ""+  }++-- * Assorted++vent = fist+  { iname    = "vent"+  , ifreq    = [("vent", 100)]+  , icount   = 1+  , iverbHit = "menace"+  , iaspects = [Periodic $ 1 + d 2]+  , ieffects = [Explode "boiling water"]+  , ifeature = [Durable, Identified]+  , idesc    = ""+  }
+ GameDefinition/Content/ItemKindShrapnel.hs view
@@ -0,0 +1,239 @@+-- | Shrapnel definitions.+module Content.ItemKindShrapnel ( shrapnels ) where++import Game.LambdaHack.Common.Color+import Game.LambdaHack.Common.Dice+import Game.LambdaHack.Common.Effect+import Game.LambdaHack.Common.Flavour+import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Content.ItemKind++shrapnels :: [ItemKind]+shrapnels =+  [fragrance, pheromone, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, mistHealing, mistWounding, distortion, waste, burningOil2, burningOil3, burningOil4, explosionBlast10, explosionBlast20, glassPiece, smoke, boilingWater, glue]++fragrance,    pheromone, firecracker2, firecracker3, firecracker4, firecracker5, firecracker6, firecracker7, mistHealing, mistWounding, distortion, waste, burningOil2, burningOil3, burningOil4, explosionBlast10, explosionBlast20, glassPiece, smoke, boilingWater, glue :: ItemKind++-- * Parameterized shrapnel++burningOil :: Int -> ItemKind+burningOil n = ItemKind+  { isymbol  = '*'+  , iname    = "burning oil"+  , ifreq    = [("burning oil" <+> tshow n, 1)]+  , iflavour = zipFancy [BrYellow]+  , icount   = intToDice (n * 4)+  , irarity  = [(1, 1)]+  , iverbHit = "burn"+  , iweight  = 1+  , iaspects = [AddLight 2]+  , ieffects = [ Burn (n `div` 2)+               , Paralyze (intToDice $ n `div` 2) ]  -- tripping on oil+  , ifeature = [ toVelocity (min 100 $ n * 7)+               , Fragile, Identified ]+  , idesc    = "Sticky oil, burning brightly."+  , ikit     = []+  }+burningOil2 = burningOil 2+burningOil3 = burningOil 3+burningOil4 = burningOil 4+explosionBlast :: Int -> ItemKind+explosionBlast n = ItemKind+  { isymbol  = '*'+  , iname    = "explosion blast"+  , ifreq    = [("explosion blast" <+> tshow n, 1)]+  , iflavour = zipPlain [BrRed]+  , icount   = 12  -- 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]+  , ifeature = [Fragile, toLinger 10, Identified]+  , idesc    = ""+  , ikit     = []+  }+explosionBlast10 = explosionBlast 10+explosionBlast20 = explosionBlast 20+firecracker :: Int -> ItemKind+firecracker n = ItemKind+  { isymbol  = '*'+  , iname    = "firecracker"+  , ifreq    = [("firecracker" <+> tshow n, 1)]+  , iflavour = zipPlain [stdCol !! (n `mod` length stdCol)]+  , icount   = intToDice $ 2 * n+  , irarity  = [(1, 1)]+  , iverbHit = "crack"+  , iweight  = 1+  , iaspects = [AddLight $ intToDice $ n `div` 2]+  , ieffects = [Burn 1, Explode $ "firecracker" <+> tshow (n - 1)]+  , ifeature = [ ToThrow $ ThrowMod (n * 10) 20+               , Fragile, Identified ]+  , idesc    = ""+  , ikit     = []+  }+firecracker7 = firecracker 7+firecracker6 = firecracker 6+firecracker5 = firecracker 5+firecracker4 = firecracker 4+firecracker3 = firecracker 3+firecracker2 = firecracker 2++-- * Assorted++fragrance = ItemKind+  { isymbol  = '\''+  , iname    = "fragrance"+  , ifreq    = [("fragrance", 1)]+  , iflavour = zipFancy [Magenta]+  , icount   = 15+  , irarity  = [(1, 1)]+  , iverbHit = "engulf"+  , iweight  = 1+  , iaspects = []+  , ieffects = [Impress]+  , ifeature = [ toVelocity 13  -- the slowest that travels at least 2 steps+               , Fragile, Identified ]+  , idesc    = ""+  , ikit     = []+  }+pheromone = ItemKind+  { isymbol  = '\''+  , iname    = "musky whiff"+  , ifreq    = [("pheromone", 1)]+  , iflavour = zipFancy [BrMagenta]+  , icount   = 8+  , irarity  = [(1, 1)]+  , iverbHit = "tempt"+  , iweight  = 1+  , iaspects = []+  , ieffects = [Dominate]+  , 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+  , irarity  = [(1, 1)]+  , iverbHit = "revitalize"+  , iweight  = 1+  , iaspects = [AddLight 1]+  , ieffects = [RefillHP 2]+  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)+               , Fragile, Identified ]+  , idesc    = ""+  , ikit     = []+  }+mistWounding = ItemKind+  { isymbol  = '\''+  , iname    = "mist"+  , ifreq    = [("wounding mist", 1)]+  , iflavour = zipFancy [White]+  , icount   = 13+  , irarity  = [(1, 1)]+  , iverbHit = "devitalize"+  , iweight  = 1+  , iaspects = []+  , ieffects = [RefillHP (-2)]+  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)+               , Fragile, Identified ]+  , idesc    = ""+  , ikit     = []+  }+distortion = ItemKind+  { isymbol  = 'v'+  , iname    = "vortex"+  , ifreq    = [("distortion", 1)]+  , iflavour = zipFancy [White]+  , icount   = 4+  , irarity  = [(1, 1)]+  , iverbHit = "engulf"+  , iweight  = 1+  , iaspects = []+  , ieffects = [Teleport $ 15 + d 10]+  , ifeature = [ toVelocity 7  -- the slowest that gets anywhere (1 step only)+               , Fragile, Identified ]+  , idesc    = ""+  , ikit     = []+  }+waste = ItemKind+  { isymbol  = '*'+  , iname    = "waste"+  , ifreq    = [("waste", 1)]+  , iflavour = zipPlain [Brown]+  , icount   = 10+  , irarity  = [(1, 1)]+  , iverbHit = "splosh"+  , iweight  = 50+  , iaspects = []+  , ieffects = [RefillHP (-1)]+  , ifeature = [ ToThrow $ ThrowMod 28 50+               , Fragile, Identified ]+  , idesc    = ""+  , ikit     = []+  }+glassPiece = ItemKind  -- when blowing up windows+  { isymbol  = '*'+  , iname    = "glass piece"+  , ifreq    = [("glass piece", 1)]+  , iflavour = zipPlain [BrBlue]+  , icount   = 17+  , irarity  = [(1, 1)]+  , iverbHit = "cut"+  , iweight  = 10+  , iaspects = []+  , ieffects = [Hurt (1 * d 1)]+  , ifeature = [toLinger 20, Fragile, Identified]+  , idesc    = ""+  , ikit     = []+  }+smoke = ItemKind  -- when stuff burns out+  { isymbol  = '\''+  , iname    = "smoke"+  , ifreq    = [("smoke", 1), ("firecracker 1", 1)]+  , iflavour = zipPlain [BrBlack]+  , icount   = 19+  , irarity  = [(1, 1)]+  , iverbHit = "choke"+  , iweight  = 1+  , iaspects = []+  , ieffects = []+  , ifeature = [ toVelocity 21, Fragile, Identified ]+  , idesc    = ""+  , ikit     = []+  }+boilingWater = ItemKind+  { isymbol  = '*'+  , iname    = "boiling water"+  , ifreq    = [("boiling water", 1)]+  , iflavour = zipPlain [BrWhite]+  , icount   = 9+  , irarity  = [(1, 1)]+  , iverbHit = "boil"+  , iweight  = 5+  , iaspects = []+  , ieffects = [Burn 1]+  , ifeature = [toVelocity 50, Fragile, Identified]+  , idesc    = ""+  , ikit     = []+  }+glue = ItemKind+  { isymbol  = '*'+  , iname    = "hoof glue"+  , ifreq    = [("glue", 1)]+  , iflavour = zipPlain [BrYellow]+  , icount   = 14+  , irarity  = [(1, 1)]+  , iverbHit = "glue"+  , iweight  = 20+  , iaspects = []+  , ieffects = [Paralyze (3 + d 3)]+  , ifeature = [toVelocity 40, Fragile, Identified]+  , idesc    = ""+  , ikit     = []+  }
GameDefinition/Content/ModeKind.hs view
@@ -1,7 +1,7 @@ -- | The type of kinds of game modes for LambdaHack. module Content.ModeKind ( cdefs ) where -import qualified Data.EnumMap.Strict as EM+import qualified Data.IntMap.Strict as IM  import Game.LambdaHack.Common.ContentDef import Game.LambdaHack.Content.ModeKind@@ -13,40 +13,71 @@   , getFreq = mfreq   , validate = validateModeKind   , content =-      [campaign, skirmish, battle, pvp, coop, defense, testCampaign, testSkirmish, testBattle, testPvP, testCoop, testDefense, peekCampaign, peekSkirmish]+      [campaign, duel, skirmish, ambush, battle, safari, pvp, coop, defense]   }-campaign,        skirmish, battle, pvp, coop, defense, testCampaign, testSkirmish, testBattle, testPvP, testCoop, testDefense, peekCampaign, peekSkirmish :: ModeKind+campaign,        duel, skirmish, ambush, battle, safari, pvp, coop, defense :: ModeKind  campaign = ModeKind-  { msymbol  = 'r'+  { msymbol  = 'a'   , mname    = "campaign"   , mfreq    = [("campaign", 1)]   , mplayers = playersCampaign   , mcaves   = cavesCampaign+  , mdesc    = "Don't let wanton curiosity, greed and the creeping abstraction madness keep you down there in the darkness for too long!"   } +duel = ModeKind+  { msymbol  = 'u'+  , mname    = "duel"+  , mfreq    = [("duel", 1)]+  , mplayers = playersDuel+  , mcaves   = cavesSkirmish+  , mdesc    = "You disagreed about the premises of a relative completeness theorem and there's only one way to settle that."+  }+ skirmish = ModeKind   { msymbol  = 'k'   , mname    = "skirmish"   , mfreq    = [("skirmish", 1)]   , mplayers = playersSkirmish-  , mcaves   = cavesCombat+  , mcaves   = cavesSkirmish+  , mdesc    = "The scoring system of a programming contest fails to determine the winning team and participants take matters into their own hands."   } +ambush = ModeKind+  { msymbol  = 'm'+  , mname    = "ambush"+  , mfreq    = [("ambush", 1)]+  , mplayers = playersAmbush+  , mcaves   = cavesAmbush+  , mdesc    = "Surprising, striking ideas and fast execution are what makes or breaks a creative team!"+  }+ battle = ModeKind   { msymbol  = 'b'   , mname    = "battle"   , mfreq    = [("battle", 1)]   , mplayers = playersBattle   , mcaves   = cavesBattle+  , mdesc    = "Odds are stacked against those that unleash the horrors of abstraction."   } +safari = ModeKind+  { msymbol  = 'f'+  , mname    = "safari"+  , mfreq    = [("safari", 1)]+  , mplayers = playersSafari+  , mcaves   = cavesSafari+  , mdesc    = "In this simulation you'll discover the joys of hunting the most exquisite of Earth's flora and fauna, both animal and semi-intelligent (exit at the bottommost level)."+  }+ pvp = ModeKind   { msymbol  = 'v'   , mname    = "PvP"   , mfreq    = [("PvP", 1)]   , mplayers = playersPvP-  , mcaves   = cavesCombat+  , mcaves   = cavesSkirmish+  , mdesc    = "(Not usable right now.) This is a fight to the death between two human-controlled teams."   }  coop = ModeKind@@ -55,6 +86,7 @@   , mfreq    = [("Coop", 1)]   , mplayers = playersCoop   , mcaves   = cavesCampaign+  , mdesc    = "(This mode is intended solely for automated testing.)"   }  defense = ModeKind@@ -63,97 +95,84 @@   , mfreq    = [("defense", 1)]   , mplayers = playersDefense   , mcaves   = cavesCampaign-  }--testCampaign = ModeKind-  { msymbol  = 't'-  , mname    = "testCampaign"-  , mfreq    = [("testCampaign", 1)]-  , mplayers = playersTestCampaign-  , mcaves   = cavesCampaign-  }--testSkirmish = ModeKind-  { msymbol  = 't'-  , mname    = "testSkirmish"-  , mfreq    = [("testSkirmish", 1)]-  , mplayers = playersTestSkirmish-  , mcaves   = cavesCombat-  }--testBattle = ModeKind-  { msymbol  = 't'-  , mname    = "testBattle"-  , mfreq    = [("testBattle", 1)]-  , mplayers = playersTestBattle-  , mcaves   = cavesBattle-  }--testPvP = ModeKind-  { msymbol  = 't'-  , mname    = "testPvP"-  , mfreq    = [("testPvP", 1)]-  , mplayers = playersTestPvP-  , mcaves   = cavesCombat-  }--testCoop = ModeKind-  { msymbol  = 't'-  , mname    = "testCoop"-  , mfreq    = [("testCoop", 1)]-  , mplayers = playersTestCoop-  , mcaves   = cavesCampaign-  }--testDefense = ModeKind-  { msymbol  = 't'-  , mname    = "testDefense"-  , mfreq    = [("testDefense", 1)]-  , mplayers = playersTestDefense-  , mcaves   = cavesCampaign-  }--peekCampaign = ModeKind-  { msymbol  = 'p'-  , mname    = "peekCampaign"-  , mfreq    = [("peekCampaign", 1)]-  , mplayers = playersPeekCampaign-  , mcaves   = cavesCampaign-  }--peekSkirmish = ModeKind-  { msymbol  = 'p'-  , mname    = "peekSkirmish"-  , mfreq    = [("peekSkirmish", 1)]-  , mplayers = playersPeekSkirmish-  , mcaves   = cavesCombat+  , mdesc    = "Don't let the humans defile your abstract secrets and flee, like the vulgar, literal, base scoundrels that they are!"   }  -playersCampaign, playersSkirmish, playersBattle, playersPvP, playersCoop, playersDefense, playersTestCampaign, playersTestSkirmish, playersTestBattle, playersTestPvP, playersTestCoop, playersTestDefense, playersPeekCampaign, playersPeekSkirmish :: Players+playersCampaign, playersDuel, playersSkirmish, playersAmbush, playersBattle, playersSafari, playersPvP, playersCoop, playersDefense :: Players  playersCampaign = Players-  { playersList = [ playerHero {playerInitial = 1}-                  , playerMonster ]-  , playersEnemy = [("Adventurer Party", "Monster Hive")]-  , playersAlly = [] }+  { playersList = [ playerHero+                  , playerMonster+                  , playerAnimal ]+  , playersEnemy = [ ("Adventurer Party", "Monster Hive")+                   , ("Adventurer Party", "Animal Kingdom") ]+  , playersAlly = [("Monster Hive", "Animal Kingdom")] } -playersSkirmish = Players-  { playersList = [ playerHero {playerName = "White"}-                  , playerAntiHero {playerName = "Purple"}+playersDuel = Players+  { playersList = [ playerHero { playerName = "White Recursive"+                               , playerInitial = 1 }+                  , playerAntiHero { playerName = "Red Iterative"+                                   , playerInitial = 1 }                   , playerHorror ]-  , playersEnemy = [ ("White", "Purple")-                   , ("White", "Horror Den")-                   , ("Purple", "Horror Den") ]+  , playersEnemy = [ ("White Recursive", "Red Iterative")+                   , ("White Recursive", "Horror Den")+                   , ("Red Iterative", "Horror Den") ]   , playersAlly = [] } +playersSkirmish = playersDuel+  { playersList = [ playerHero {playerName = "White Haskell"}+                  , playerAntiHero {playerName = "Purple Agda"}+                  , playerHorror ]+  , playersEnemy = [ ("White Haskell", "Purple Agda")+                   , ("White Haskell", "Horror Den")+                   , ("Purple Agda", "Horror Den") ] }++playersAmbush = playersDuel+  { playersList = [ playerHero {playerName = "Yellow Idris"}+                  , playerAntiHero {playerName = "Blue Epigram"}+                  , playerHorror ]+  , playersEnemy = [ ("Yellow Idris", "Blue Epigram")+                   , ("Yellow Idris", "Horror Den")+                   , ("Blue Epigram", "Horror Den") ] }+ playersBattle = Players   { playersList = [ playerHero {playerInitial = 5}-                  , playerMonster { playerInitial = 30-                                  , playerSpawn = 0 } ]-  , playersEnemy = [("Adventurer Party", "Monster Hive")]-  , playersAlly = [] }+                  , playerMonster { playerInitial = 15+                                  , playerIsSpawn = False }+                  , playerAnimal { playerInitial = 10+                                 , playerIsSpawn = False } ]+  , playersEnemy = [ ("Adventurer Party", "Monster Hive")+                   , ("Adventurer Party", "Animal Kingdom") ]+  , playersAlly = [("Monster Hive", "Animal Kingdom")] } +playersSafari = Players+  { playersList = [ playerMonster { playerName = "Monster Tourist Office"+                                  , playerIsSpawn = False+                                  , playerEntry = -4+                                  , playerInitial = 10+                                  , playerAI = False+                                  , playerUI = True }+                  , playerCivilian { playerName = "Hunam Convict Pack"+                                   , playerEntry = -4 }+                  , playerAnimal { playerName =+                                     "Animal Magnificent Specimen Variety"+                                 , playerIsSpawn = False+                                 , playerEntry = -7+                                 , playerInitial = 7 }+                  , playerAnimal { playerName =+                                     "Animal Exquisite Herds and Packs"+                                 , playerIsSpawn = False+                                 , playerEntry = -10+                                 , playerInitial = 20 } ]+  , playersEnemy = [ ("Monster Tourist Office", "Hunam Convict Pack")+                   , ("Monster Tourist Office",+                      "Animal Magnificent Specimen Variety")+                   , ("Monster Tourist Office",+                      "Animal Exquisite Herds and Packs") ]+  , playersAlly = [( "Animal Magnificent Specimen Variety"+                   , "Animal Exquisite Herds and Packs" )] }+ playersPvP = Players   { playersList = [ playerHero {playerName = "Red"}                   , playerHero {playerName = "Blue"}@@ -164,138 +183,117 @@   , playersAlly = [] }  playersCoop = Players-  { playersList = [ playerHero { playerName = "Coral"-                               , playerInitial = 1 }-                  , playerHero { playerName = "Amber"-                               , playerInitial = 1 }-                  , playerMonster ]+  { playersList = [ playerAntiHero { playerName = "Coral" }+                  , playerAntiHero { playerName = "Amber"+                                   , playerLeader = False }+                  , playerAntiHero { playerName = "Green" }+                  , playerAnimal { playerUI = True }+                  , playerMonster+                  , playerMonster { playerName = "Leaderless Monster Hive"+                                  , playerLeader = False } ]   , playersEnemy = [ ("Coral", "Monster Hive")-                   , ("Amber", "Monster Hive") ]-  , playersAlly = [("Coral", "Amber")] }+                   , ("Amber", "Monster Hive")+                   , ("Animal Kingdom", "Leaderless Monster Hive") ]+  , playersAlly = [ ("Coral", "Amber")+                  , ("Coral", "Green")+                  , ("Amber", "Green")+                  , ("Green", "Animal Kingdom")+                  , ("Green", "Monster Hive")+                  , ("Green", "Leaderless Monster Hive") ] }  playersDefense = Players   { playersList = [ playerMonster { playerInitial = 1-                                  , playerAiLeader = False-                                  , playerHuman = True-                                  , playerUI = True }-                  , playerAntiHero {playerName = "Green"}-                  , playerAntiHero {playerName = "Yellow"}-                  , playerAntiHero {playerName = "Cyan"} ]-  , playersEnemy = [ ("Green", "Monster Hive")-                   , ("Yellow", "Monster Hive")-                   , ("Cyan", "Monster Hive") ]-  , playersAlly = [ ("Green", "Yellow")-                  , ("Green", "Cyan")-                  , ("Yellow", "Cyan") ] }--playersTestCampaign = playersCampaign-  { playersList = [ playerHero { playerInitial = 5-                               , playerAiLeader = True-                               , playerHuman = False }-                  , playerMonster ] }--playersTestSkirmish = playersSkirmish-  { playersList = [ playerHero { playerName = "White"-                               , playerAiLeader = True-                               , playerHuman = False }-                  , playerAntiHero { playerName = "Purple" }-                  , playerHorror ] }--playersTestBattle = playersBattle-  { playersList = [ playerHero { playerInitial = 5-                               , playerAiLeader = True-                               , playerHuman = False }-                  , playerMonster { playerInitial = 30-                                  , playerSpawn = 0 } ] }--playersTestPvP = playersPvP-  { playersList = [ playerHero { playerName = "Red"-                               , playerAiLeader = True-                               , playerHuman = False }-                  , playerHero { playerName = "Blue"-                               , playerAiLeader = True-                               , playerHuman = False }-                  , playerHorror ] }--playersTestCoop = playersCoop-  { playersList = [ playerHero { playerName = "Coral"-                               , playerAiLeader = True-                               , playerHuman = False }-                  , playerHero { playerName = "Amber"-                               , playerAiLeader = True-                               , playerHuman = False }-                  , playerMonster ] }--playersTestDefense = playersDefense-  { playersList = [ playerMonster { playerInitial = 1+                                  , playerAI = False                                   , playerUI = True }-                  , playerAntiHero {playerName = "Green"}-                  , playerAntiHero {playerName = "Yellow"}-                  , playerAntiHero {playerName = "Cyan"} ] }--playersPeekCampaign = playersCampaign-  { playersList = [ playerHero {playerInitial = 1}-                  , playerMonster {playerUI = True} ] }--playersPeekSkirmish = playersSkirmish-  { playersList = [ playerHero {playerName = "White"}-                  , playerAntiHero { playerName = "Purple"-                                   , playerUI = True }-                  , playerHorror ] }-+                  , playerAntiHero { playerName = "Yellow"+                                   , playerInitial = 10 }+                  , playerAnimal ]+  , playersEnemy = [ ("Yellow", "Monster Hive")+                   , ("Yellow", "Animal Kingdom") ]+  , playersAlly = [("Monster Hive", "Animal Kingdom")] } -playerHero, playerAntiHero, playerMonster, playerHorror :: Player+playerHero, playerAntiHero, playerCivilian, playerMonster, playerAnimal, playerHorror :: Player  playerHero = Player   { playerName = "Adventurer Party"   , playerFaction = "hero"-  , playerSpawn = 0-  , playerEntry = toEnum (-1)+  , playerIsSpawn = False+  , playerIsHero = True+  , playerEntry = -1   , playerInitial = 3-  , playerAiLeader = False-  , playerAiOther = True-  , playerHuman = True+  , playerLeader = True+  , playerAI = False   , playerUI = True   }  playerAntiHero = playerHero-  { playerAiLeader = True-  , playerHuman = False+  { playerAI = True   , playerUI = False   } +playerCivilian = Player+  { playerName = "Civilian Crowd"+  , playerFaction = "civilian"+  , playerIsSpawn = False+  , playerIsHero = False+  , playerEntry = -1+  , playerInitial = 3+  , playerLeader = False  -- unorganized+  , playerAI = True+  , playerUI = False+  }+ playerMonster = Player   { playerName = "Monster Hive"   , playerFaction = "monster"-  , playerSpawn = 50-  , playerEntry = toEnum (-3)+  , playerIsSpawn = True+  , playerIsHero = False+  , playerEntry = -3   , playerInitial = 5-  , playerAiLeader = True-  , playerAiOther = True-  , playerHuman = False+  , playerLeader = True+  , playerAI = True   , playerUI = False   } +playerAnimal = Player+  { playerName = "Animal Kingdom"+  , playerFaction = "animal"+  , playerIsSpawn = True+  , playerIsHero = False+  , playerEntry = -2+  , playerInitial = 3+  , playerLeader = False+  , playerAI = True+  , playerUI = False+  }+ playerHorror = Player   { playerName = "Horror Den"   , playerFaction = "horror"-  , playerSpawn = 0-  , playerEntry = toEnum (-1)+  , playerIsSpawn = False+  , playerIsHero = False+  , playerEntry = -1   , playerInitial = 0-  , playerAiLeader = True-  , playerAiOther = True-  , playerHuman = False+  , playerLeader = False+  , playerAI = True   , playerUI = False   }  -cavesCampaign, cavesCombat, cavesBattle :: Caves+cavesCampaign, cavesSkirmish, cavesAmbush, cavesBattle, cavesSafari :: Caves -cavesCampaign = EM.fromList [ (toEnum (-1), ("caveRogue", Just True))-                            , (toEnum (-2), ("caveRogue", Nothing))-                            , (toEnum (-3), ("caveEmpty", Nothing))-                            , (toEnum (-10), ("caveNoise", Nothing))]+cavesCampaign = IM.fromList $ [ (-1, ("caveRogue", Just True))+                              , (-2, ("caveRogue", Nothing))+                              , (-3, ("caveEmpty", Nothing)) ]+                              ++ zip [-4, -5..(-9)] (repeat ("dng", Nothing))+                              ++ [(-10, ("caveNoise", Nothing))] -cavesCombat = EM.fromList [(toEnum (-3), ("caveCombat", Nothing))]+cavesSkirmish = IM.fromList [(-3, ("caveSkirmish", Nothing))] -cavesBattle = EM.fromList [(toEnum (-3), ("caveBattle", Nothing))]+cavesAmbush = IM.fromList [(-5, ("caveAmbush", Nothing))]++cavesBattle = IM.fromList [(-3, ("caveBattle", Nothing))]++cavesSafari = IM.fromList [ (-4, ("caveSafari1", Nothing))+                          , (-7, ("caveSafari2", Nothing))+                          , (-10, ("caveSafari3", Just False)) ]
GameDefinition/Content/PlaceKind.hs view
@@ -11,24 +11,69 @@   , getFreq = pfreq   , validate = validatePlaceKind   , content =-      [rect, pillar, pillarC, pillar3, colonnade, colonnadeW]+      [rect, ruin, collapsed, collapsed2, collapsed3, collapsed4, pillar, pillarC, pillar3, colonnade, colonnade2, colonnade3, lampPost, lampPost2, lampPost3, lampPost4, treeShade, treeShade2, treeShade3]   }-rect,        pillar, pillarC, pillar3, colonnade, colonnadeW :: PlaceKind+rect,        ruin, collapsed, collapsed2, collapsed3, collapsed4, pillar, pillarC, pillar3, colonnade, colonnade2, colonnade3, lampPost, lampPost2, lampPost3, lampPost4, treeShade, treeShade2, treeShade3 :: PlaceKind  rect = PlaceKind  -- Valid for any nonempty area, hence low frequency.   { psymbol  = 'r'   , pname    = "room"-  , pfreq    = [("rogue", 100)]+  , pfreq    = [("rogue", 100), ("ambush", 8)]+  , prarity  = [(1, 1)]   , pcover   = CStretch   , pfence   = FNone   , ptopLeft = [ "--"                , "|."                ]+  , poverride = []   }+ruin = PlaceKind+  { psymbol  = 'R'+  , pname    = "ruin"+  , pfreq    = [("ambush", 17), ("battle", 100)]+  , prarity  = [(1, 1)]+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "--"+               , "|X"+               ]+  , poverride = []+  }+collapsed = PlaceKind+  { psymbol  = 'c'+  , pname    = "collapsed cavern"+  , pfreq    = [("noise", 1)]+  , prarity  = [(1, 1)]+  , pcover   = CStretch+  , pfence   = FNone+  , ptopLeft = [ "O"+               ]+  , poverride = []+  }+collapsed2 = collapsed+  { pfreq    = [("noise", 100), ("battle", 50)]+  , ptopLeft = [ "XXO"+               , "XOO"+               ]+  }+collapsed3 = collapsed+  { pfreq    = [("noise", 200), ("battle", 50)]+  , ptopLeft = [ "XXXO"+               , "XOOO"+               ]+  }+collapsed4 = collapsed+  { pfreq    = [("noise", 400), ("battle", 200)]+  , ptopLeft = [ "XXXO"+               , "XXXO"+               , "XOOO"+               ]+  } pillar = PlaceKind   { psymbol  = 'p'   , pname    = "pillar room"   , pfreq    = [("rogue", 1000)]  -- larger rooms require support pillars+  , prarity  = [(1, 1)]   , pcover   = CStretch   , pfence   = FNone   , ptopLeft = [ "-----"@@ -37,6 +82,7 @@                , "|...."                , "|...."                ]+  , poverride = []   } pillarC = pillar   { ptopLeft = [ "-----"@@ -57,15 +103,83 @@ colonnade = PlaceKind   { psymbol  = 'c'   , pname    = "colonnade"-  , pfreq    = [("rogue", 500)]+  , pfreq    = [("rogue", 60)]+  , prarity  = [(1, 1)]   , pcover   = CAlternate   , pfence   = FFloor   , ptopLeft = [ "O."                , ".O"                ]+  , poverride = []   }-colonnadeW = colonnade+colonnade2 = colonnade   { ptopLeft = [ "O."                , ".."+               ]+  }+colonnade3 = colonnade+  { pfreq    = [("rogue", 6)]+  , ptopLeft = [ ".."+               , ".O"+               ]+  }+lampPost = PlaceKind+  { psymbol  = 'l'+  , pname    = "lamp post"+  , pfreq    = [("ambush", 30), ("battle", 10)]+  , prarity  = [(1, 1)]+  , pcover   = CVerbatim+  , pfence   = FNone+  , ptopLeft = [ "X.X"+               , ".O."+               , "X.X"+               ]+  , poverride = [('O', "lampPostOver_O")]+  }+lampPost2 = lampPost+  { ptopLeft = [ "..."+               , ".O."+               , "..."+               ]+  }+lampPost3 = lampPost+  { ptopLeft = [ "XX.XX"+               , "X...X"+               , "..O.."+               , "X...X"+               , "XX.XX"+               ]+  }+lampPost4 = lampPost+  { ptopLeft = [ "X...X"+               , "....."+               , "..O.."+               , "....."+               , "X...X"+               ]+  }+treeShade = PlaceKind+  { psymbol  = 't'+  , pname    = "tree shade"+  , pfreq    = [("skirmish", 100)]+  , prarity  = [(1, 1)]+  , pcover   = CVerbatim+  , pfence   = FNone+  , ptopLeft = [ "sss"+               , "XOs"+               , "XXs"+               ]+  , poverride = [('O', "treeShadeOver_O"), ('s', "treeShadeOver_s")]+  }+treeShade2 = treeShade+  { ptopLeft = [ "sss"+               , "XOs"+               , "Xss"+               ]+  }+treeShade3 = treeShade+  { ptopLeft = [ "sss"+               , "sOs"+               , "XXs"                ]   }
GameDefinition/Content/RuleKind.hs view
@@ -2,7 +2,6 @@ -- | Game rules and assorted game setup data for LambdaHack. module Content.RuleKind ( cdefs ) where -import Control.Arrow (first) import Language.Haskell.TH.Syntax import System.FilePath @@ -10,10 +9,6 @@ import qualified Paths_LambdaHack as Self (getDataFileName, version)  import Game.LambdaHack.Common.ContentDef-import qualified Game.LambdaHack.Common.Effect as Effect-import qualified Game.LambdaHack.Common.Feature as F-import Game.LambdaHack.Common.HumanCmd-import qualified Game.LambdaHack.Common.Key as K import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.RuleKind @@ -33,19 +28,15 @@   , rname          = "standard LambdaHack ruleset"   , rfreq          = [("standard", 100)]   -- Check whether one position is accessible from another.-  -- Precondition: the two positions are next to each other.-  -- Apart of checking the target tile, we forbid diagonal movement-  -- to and from doors.+  -- Precondition: the two positions are next to each other+  -- and the target tile is walkable. For LambdaHack we forbid+  -- diagonal movement to and from doors.   , raccessible    = Nothing-  , raccessibleDoor = Just $ \spos tpos ->-                                not $ isDiagonal $ displacement spos tpos+  , raccessibleDoor =+      Just $ \spos tpos -> not $ isDiagonal $ spos `vectorToFrom` tpos   , rtitle         = "LambdaHack"   , rpathsDataFile = Self.getDataFileName   , rpathsVersion  = Self.version-  , ritemMelee     = ")"-  , ritemRanged    = "|"-  -- Wasting weapons and armour would be too cruel to the player.-  , ritemProject   = "!?|/"   -- The strings containing the default configuration file   -- included from config.ui.default.   , rcfgUIName = "config.ui"@@ -74,140 +65,11 @@       qAddDependentFile path       x <- qRunIO (readFile path)       lift x)-  , rhumanCommands = map (first K.mkKM)-      -- All commands are defined here, except some movement and leader picking-      -- commands. All commands are shown on help screens except debug commands-      -- and macros with empty descriptions.-      -- The order below determines the order on the help screens.-      -- Remember to put commands that show information (e.g., enter targeting-      -- mode) first.--      -- Main Menu, which apart of these includes a few extra commands-      [ ("CTRL-x", (CmdMenu, GameExit))-      , ("CTRL-r", (CmdMenu, GameRestart "campaign"))-      , ("CTRL-k", (CmdMenu, GameRestart "skirmish"))-      , ("CTRL-v", (CmdMenu, GameRestart "PvP"))-      , ("CTRL-o", (CmdMenu, GameRestart "Coop"))-      , ("CTRL-e", (CmdMenu, GameRestart "defense"))-      , ("CTRL-d", (CmdMenu, GameDifficultyCycle))--      -- Movement and terrain alteration-      , ("less", (CmdMove, TriggerTile-           [ TriggerFeature { verb = "ascend"-                            , object = "a level"-                            , feature = F.Cause (Effect.Ascend 1) }-           , TriggerFeature { verb = "escape"-                            , object = "dungeon"-                            , feature = F.Cause (Effect.Escape 1) } ]))-      , ("CTRL-less", (CmdMove, TriggerTile-           [ TriggerFeature { verb = "ascend"-                            , object = "10 levels"-                            , feature = F.Cause (Effect.Ascend 10) } ]))-      , ("greater", (CmdMove, TriggerTile-           [ TriggerFeature { verb = "descend"-                            , object = "a level"-                            , feature = F.Cause (Effect.Ascend (-1)) }-           , TriggerFeature { verb = "escape"-                            , object = "dungeon"-                            , feature = F.Cause (Effect.Escape (-1)) } ]))-      , ("CTRL-greater", (CmdMove, TriggerTile-           [ TriggerFeature { verb = "descend"-                            , object = "10 levels"-                            , feature = F.Cause (Effect.Ascend (-10)) } ]))-      , ("CTRL-semicolon", (CmdMove, StepToTarget))-      , ("semicolon", (CmdMove, Macro "go to target for 100 steps"-                                      ["CTRL-semicolon", "P"]))-      , ("x", (CmdMove, Macro "explore the closest unknown spot"-                              [ "BackSpace"-                              , "CTRL-question", "CTRL-semicolon", "P" ]))-      , ("X", (CmdMove, Macro "autoexplore 100 times"-                              [ "BackSpace"-                              , "'", "CTRL-question", "CTRL-semicolon", "'"-                              , "P" ]))-      , ("R", (CmdMove, Macro "rest (wait 100 times)" ["KP_Begin", "P"]))-      , ("c", (CmdMove, AlterDir-           [ AlterFeature { verb = "close"-                          , object = "door"-                          , feature = F.CloseTo "vertical closed door Lit" }-           , AlterFeature { verb = "close"-                          , object = "door"-                          , feature = F.CloseTo "horizontal closed door Lit" }-           , AlterFeature { verb = "close"-                          , object = "door"-                          , feature = F.CloseTo "vertical closed door Dark" }-           , AlterFeature { verb = "close"-                          , object = "door"-                          , feature = F.CloseTo "horizontal closed door Dark" }-           ]))-      , ("o", (CmdMove, AlterDir-           [ AlterFeature { verb = "open"-                          , object = "door"-                          , feature = F.OpenTo "vertical open door Lit" }-           , AlterFeature { verb = "open"-                          , object = "door"-                          , feature = F.OpenTo "horizontal open door Lit" }-           , AlterFeature { verb = "open"-                          , object = "door"-                          , feature = F.OpenTo "vertical open door Dark" }-           , AlterFeature { verb = "open"-                          , object = "door"-                          , feature = F.OpenTo "horizontal open door Dark" }-           ]))--      -- Inventory and items-      , ("I", (CmdItem, Inventory))-      , ("g", (CmdItem, Pickup))-      , ("d", (CmdItem, Drop))-      , ("q", (CmdItem, Apply [ApplyItem { verb = "quaff"-                                         , object = "potion"-                                         , symbol = '!' }]))-      , ("r", (CmdItem, Apply [ApplyItem { verb = "read"-                                         , object = "scroll"-                                         , symbol = '?' }]))-      , ("t", (CmdItem, Project [ApplyItem { verb = "throw"-                                           , object = "missile"-                                           , symbol = '|' }]))-      , ("z", (CmdItem, Project [ApplyItem { verb = "zap"-                                           , object = "wand"-                                           , symbol = '/' }]))--      -- Targeting-      , ("asterisk", (CmdTgt, TgtEnemy))-      , ("slash", (CmdTgt, TgtFloor))-      , ("plus", (CmdTgt, EpsIncr True))-      , ("minus", (CmdTgt, EpsIncr False))-      , ("BackSpace", (CmdTgt, TgtClear))-      , ("CTRL-question", (CmdTgt, TgtUnknown))-      , ("CTRL-I", (CmdTgt, TgtItem))-      , ("CTRL-braceleft", (CmdTgt, TgtStair True))-      , ("CTRL-braceright", (CmdTgt, TgtStair False))--      -- Assorted-      , ("question", (CmdMeta, Help))-      , ("D", (CmdMeta, History))-      , ("T", (CmdMeta, MarkSuspect))-      , ("V", (CmdMeta, MarkVision))-      , ("S", (CmdMeta, MarkSmell))-      , ("Tab", (CmdMeta, MemberCycle))-      , ("ISO_Left_Tab", (CmdMeta, MemberBack))-      , ("equal", (CmdMeta, SelectActor))-      , ("underscore", (CmdMeta, SelectNone))-      , ("p", (CmdMeta, Repeat 1))-      , ("P", (CmdMeta, Repeat 100))-      , ("CTRL-p", (CmdMeta, Repeat 1000))-      , ("apostrophe", (CmdMeta, Record))-      , ("space", (CmdMeta, Clear))-      , ("Escape", (CmdMeta, Cancel))-      , ("Return", (CmdMeta, Accept))--      -- Debug and others not to display in help screens-      , ("CTRL-s", (CmdDebug, GameSave))-      , ("CTRL-y", (CmdDebug, Resend))-      ]   , rfirstDeathEnds = False-  , rfovMode = Digital 12+  , rfovMode = Digital   , rsaveBkpClips = 500   , rleadLevelClips = 100   , rscoresFile = "scores"   , rsavePrefix = "save"+  , rsharedStash = True   }
GameDefinition/Content/TileKind.hs view
@@ -2,6 +2,7 @@ module Content.TileKind ( cdefs ) where  import Control.Arrow (first)+import Data.Maybe import Data.Text (Text) import qualified Data.Text as T @@ -19,11 +20,11 @@   , getFreq = tfreq   , validate = validateTileKind   , content =-      [wall, hardRock, pillar, pillarCache, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpLit, stairsLit, stairsDownLit, escapeUpLit, escapeDownLit, unknown, floorCorridorLit, floorArenaLit, floorActorLit, floorItemLit, floorActorItemLit, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit]+      [wall, hardRock, pillar, pillarCache, lampPost, burningBush, bush, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpLit, stairsLit, stairsDownLit, escapeUpLit, escapeDownLit, unknown, floorCorridorLit, floorArenaLit, floorArenaShade, floorActorLit, floorItemLit, floorActorItemLit, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit]       ++ map makeDark [wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsLit, escapeUpLit, escapeDownLit, floorCorridorLit]       ++ map makeDarkColor [stairsUpLit, stairsDownLit, floorArenaLit, floorActorLit, floorItemLit, floorActorItemLit]   }-wall,        hardRock, pillar, pillarCache, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpLit, stairsLit, stairsDownLit, escapeUpLit, escapeDownLit, unknown, floorCorridorLit, floorArenaLit, floorActorLit, floorItemLit, floorActorItemLit, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit :: TileKind+wall,        hardRock, pillar, pillarCache, lampPost, burningBush, bush, tree, wallV, wallSuspectV, doorClosedV, doorOpenV, wallH, wallSuspectH, doorClosedH, doorOpenH, stairsUpLit, stairsLit, stairsDownLit, escapeUpLit, escapeDownLit, unknown, floorCorridorLit, floorArenaLit, floorArenaShade, floorActorLit, floorItemLit, floorActorItemLit, floorRedLit, floorBlueLit, floorGreenLit, floorBrownLit :: TileKind  wall = TileKind   { tsymbol  = ' '@@ -32,6 +33,18 @@   , tcolor   = defBG   , tcolor2  = defBG   , tfeature = [Dark]+      -- Bedrock being dark is bad for AI (forces it to backtrack to explore+      -- bedrock at corridor turns) and induces human micromanagement+      -- if there can be corridors joined diagonally (humans have to check+      -- with the cursor if the dark space is bedrock or unexplored).+      -- Lit bedrock would be even worse for humans, because it's harder+      -- to guess which tiles are unknown and which can be explored bedrock.+      -- The setup of Allure is ideal, with lit bedrock that is easily+      -- distinguished from an unknown tile. However, LH follows the NetHack,+      -- not the Angband, visual tradition, so we can't improve the situation,+      -- unless we turn to subtle shades of black or non-ASCII glyphs,+      -- but that is yet different aesthetics and it's inconsistent+      -- with console frontends.   } hardRock = TileKind   { tsymbol  = ' '@@ -46,7 +59,8 @@   , tname    = "rock"   , tfreq    = [ ("cachable", 70)                , ("legendLit", 100), ("legendDark", 100)-               , ("noiseSet", 55), ("combatSet", 3), ("battleSet", 9) ]+               , ("noiseSet", 100), ("skirmishSet", 5)+               , ("battleSet", 250) ]   , tcolor   = BrWhite   , tcolor2  = defFG   , tfeature = []@@ -58,12 +72,36 @@                , ("legendLit", 100), ("legendDark", 100) ]   , tcolor   = BrWhite   , tcolor2  = defFG-  , tfeature = [Suspect, Cause $ Effect.CreateItem 1, ChangeTo "cachable"]+  , tfeature = [Cause $ Effect.CreateItem 1, ChangeTo "cachable"]   }+lampPost = TileKind+  { tsymbol  = 'O'+  , tname    = "lamp post"+  , tfreq    = [("lampPostOver_O", 90)]+  , tcolor   = BrYellow+  , tcolor2  = Brown+  , tfeature = []+  }+burningBush = TileKind+  { tsymbol  = 'O'+  , tname    = "burning bush"+  , tfreq    = [("lampPostOver_O", 10), ("ambushSet", 3), ("battleSet", 2)]+  , tcolor   = BrRed+  , tcolor2  = Red+  , tfeature = []+  }+bush = TileKind+  { tsymbol  = 'O'+  , tname    = "bush"+  , tfreq    = [("ambushSet", 100) ]+  , tcolor   = Green+  , tcolor2  = BrBlack+  , tfeature = [Dark]+  } tree = TileKind   { tsymbol  = 'O'   , tname    = "tree"-  , tfreq    = [("combatSet", 8)]+  , tfreq    = [("skirmishSet", 14), ("battleSet", 20), ("treeShadeOver_O", 1)]   , tcolor   = BrGreen   , tcolor2  = Green   , tfeature = []@@ -100,7 +138,7 @@   , tfreq    = [("vertical open door Lit", 1)]   , tcolor   = Brown   , tcolor2  = BrBlack-  , tfeature = [ Walkable, Clear+  , tfeature = [ Walkable, Clear, NoItem, NoActor                , CloseTo "vertical closed door Lit"                ]   }@@ -136,7 +174,7 @@   , tfreq    = [("horizontal open door Lit", 1)]   , tcolor   = Brown   , tcolor2  = BrBlack-  , tfeature = [ Walkable, Clear+  , tfeature = [ Walkable, Clear, NoItem, NoActor                , CloseTo "horizontal closed door Lit"                ]   }@@ -146,7 +184,7 @@   , tfreq    = [("legendLit", 100)]   , tcolor   = BrWhite   , tcolor2  = defFG-  , tfeature = [Walkable, Clear, Cause $ Effect.Ascend 1]+  , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ Effect.Ascend 1]   } stairsLit = TileKind   { tsymbol  = '>'@@ -154,7 +192,7 @@   , tfreq    = [("legendLit", 100)]   , tcolor   = BrCyan   , tcolor2  = Cyan  -- TODO-  , tfeature = [ Walkable, Clear+  , tfeature = [ Walkable, Clear, NoItem, NoActor                , Cause $ Effect.Ascend 1                , Cause $ Effect.Ascend (-1) ]   }@@ -164,7 +202,7 @@   , tfreq    = [("legendLit", 100)]   , tcolor   = BrWhite   , tcolor2  = defFG-  , tfeature = [Walkable, Clear, Cause $ Effect.Ascend (-1)]+  , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ Effect.Ascend (-1)]   } escapeUpLit = TileKind   { tsymbol  = '<'@@ -172,7 +210,7 @@   , tfreq    = [("legendLit", 100)]   , tcolor   = BrYellow   , tcolor2  = BrYellow-  , tfeature = [Walkable, Clear, Cause (Effect.Escape 1)]+  , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ Effect.Escape 1]   } escapeDownLit = TileKind   { tsymbol  = '>'@@ -180,7 +218,7 @@   , tfreq    = [("legendLit", 100)]   , tcolor   = BrYellow   , tcolor2  = BrYellow-  , tfeature = [Walkable, Clear, Cause (Effect.Escape (-1))]+  , tfeature = [Walkable, Clear, NoItem, NoActor, Cause $ Effect.Escape (-1)]   } unknown = TileKind   { tsymbol  = ' '@@ -202,20 +240,28 @@   { tsymbol  = '.'   , tname    = "stone floor"   , tfreq    = [ ("floorArenaLit", 1)-               , ("arenaSet", 1), ("noiseSet", 100), ("combatSet", 100) ]+               , ("arenaSet", 1), ("emptySet", 1), ("noiseSet", 50)+               , ("battleSet", 1000), ("skirmishSet", 100)+               , ("ambushSet", 1000) ]   } floorActorLit = floorArenaLit-  { tfreq    = [("floorActorLit", 1), ("battleSet", 100)]-  , tfeature = CanActor : tfeature floorArenaLit+  { tfreq    = []+  , tfeature = OftenActor : tfeature floorArenaLit   } floorItemLit = floorArenaLit   { tfreq    = []-  , tfeature = CanItem : tfeature floorArenaLit+  , tfeature = OftenItem : tfeature floorArenaLit   } floorActorItemLit = floorItemLit-  { tfreq    = [("legendLit", 100), ("emptySet", 1)]-  , tfeature = CanActor : tfeature floorItemLit+  { tfreq    = [("legendLit", 100)]  -- no OftenItem in legendDark+  , tfeature = OftenActor : tfeature floorItemLit   }+floorArenaShade = floorActorLit+  { tname    = "stone floor"  -- TODO: "shaded ground"+  , tfreq    = [("treeShadeOver_s", 1)]+  , tcolor2  = BrBlack+  , tfeature = Dark : tfeature floorActorLit  -- no OftenItem+  } floorRedLit = floorArenaLit   { tname    = "brick pavement"   , tfreq    = [("trailLit", 30)]@@ -243,17 +289,18 @@   }  makeDark :: TileKind -> TileKind-makeDark k = let textLit :: Text -> Text-                 textLit t = maybe t (<> "Dark") $ T.stripSuffix "Lit" t-                 litFreq = map (first textLit) $ tfreq k-                 litFeat (OpenTo t) = OpenTo $ textLit t-                 litFeat (CloseTo t) = CloseTo $ textLit t-                 litFeat (ChangeTo t) = ChangeTo $ textLit t-                 litFeat (HideAs t) = HideAs $ textLit t-                 litFeat (RevealAs t) = RevealAs $ textLit t-                 litFeat feat = feat-             in k { tfreq    = litFreq-                  , tfeature = Dark : map litFeat (tfeature k)+makeDark k = let darkText :: Text -> Text+                 darkText t = maybe t (<> "Dark") $ T.stripSuffix "Lit" t+                 darkFrequency = map (first darkText) $ tfreq k+                 darkFeat (OpenTo t) = Just $ OpenTo $ darkText t+                 darkFeat (CloseTo t) = Just $ CloseTo $ darkText t+                 darkFeat (ChangeTo t) = Just $ ChangeTo $ darkText t+                 darkFeat (HideAs t) = Just $ HideAs $ darkText t+                 darkFeat (RevealAs t) = Just $ RevealAs $ darkText t+                 darkFeat OftenItem = Nothing+                 darkFeat feat = Just $ feat+             in k { tfreq    = darkFrequency+                  , tfeature = Dark : mapMaybe darkFeat (tfeature k)                   }  makeDarkColor :: TileKind -> TileKind
GameDefinition/Main.hs view
@@ -1,50 +1,13 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--- | The main source code file of LambdaHack. Here the knot of engine--- code pieces and the LambdaHack-specific content defintions is tied,--- resulting in an executable game.+-- | The main source code file of LambdaHack the game. module Main ( main ) where -import qualified Content.ActorKind-import qualified Content.CaveKind-import qualified Content.FactionKind-import qualified Content.ItemKind-import qualified Content.ModeKind-import qualified Content.PlaceKind-import qualified Content.RuleKind-import qualified Content.TileKind-import Game.LambdaHack.Client-import Game.LambdaHack.Client.Action.ActionType-import Game.LambdaHack.Common.Action (MonadAtomic (..))-import Game.LambdaHack.Common.AtomicCmd-import Game.LambdaHack.Common.AtomicSem-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Server-import Game.LambdaHack.Server.Action.ActionType-import Game.LambdaHack.Server.AtomicSemSer---- | The game-state semantics of atomic game commands--- as computed on the server.-instance MonadAtomic ActionSer where-  execAtomic = atomicSendSem+import System.Environment (getArgs) --- | The game-state semantics of atomic game commands--- as computed on clients. Special effects (@SfxAtomic@) don't modify state.-instance MonadAtomic (ActionCli c d) where-  execAtomic (CmdAtomic cmd) = cmdAtomicSem cmd-  execAtomic (SfxAtomic _) = return ()+import TieKnot --- | Tie the LambdaHack engine clients and server code--- with the LambdaHack-specific content defintions and run the game.+-- | Tie the LambdaHack engine client, server and frontend code+-- with the game-specific content definitions, and run the game. main :: IO ()-main =-  let copsSlow = Kind.COps-        { coactor   = Kind.createOps Content.ActorKind.cdefs-        , cocave    = Kind.createOps Content.CaveKind.cdefs-        , cofaction = Kind.createOps Content.FactionKind.cdefs-        , coitem    = Kind.createOps Content.ItemKind.cdefs-        , comode    = Kind.createOps Content.ModeKind.cdefs-        , coplace   = Kind.createOps Content.PlaceKind.cdefs-        , corule    = Kind.createOps Content.RuleKind.cdefs-        , cotile    = Kind.createOps Content.TileKind.cdefs-        }-  in mainSer copsSlow executorSer $ exeFrontend executorCli executorCli+main = do+  args <- getArgs+  tieKnot args
GameDefinition/PLAYING.md view
@@ -2,35 +2,62 @@ ==================  LambdaHack is a small dungeon crawler illustrating the roguelike game engine-library also called LambdaHack. Playing the game involves walking around-the dungeon, alone or in a party of fearless adventurers, setting up ambushes,-hiding in shadow, covering tracks, breaking through to deeper caves,-bumping into monsters, doors and walls, gathering magical treasure-and making creative use of it. The bloodthirsty monsters do the same,-intelligence allowing, while tirelessly chasing the elusive heroes-by smell and sight.+of the same name. Playing the game involves exploring spooky dungeons,+alone or in a party of fearless adventurers, setting up ambushes+for unwary creatures, hiding in shadows, bumping into unspeakable horrors,+hidden passages and gorgeous magical treasure and making creative use+of it all. The madness-inspiring abominations that multiply in the depths+perform the same feats, due to their aberrant, abstract hyper-intelligence,+while tirelessly chasing the elusive heroes by sight, sound and smell.  Once the few basic command keys and on-screen symbols are learned, mastery and enjoyment of the game is the matter of tactical skill and literary imagination. To be honest, a lot of imagination is required for this rudimentary game, but it's playable and winnable.-The game also features experimental multiplayer cooperative and competitive-modes, but they are troublesome to play with the shared-screen-and shared-keyboard interface available at this time.-Contributions welcome.+Contributions are welcome.  -Dungeon--------+Heroes+------  The heroes are marked on the map with symbols `@` and `1` through `9`. Their goal is to explore the dungeon, battle the horrors within, gather as much gold and gems as possible, and escape to tell the tale.++The currently chosen party leader is highlighted on the screen+and his attributes are displayed at the bottommost status line,+which in its most complex form may look as follows.++    *@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 other status line describes the current location in relation to the party.++    5  Lofty hall   [33% seen] Cursor: 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.+++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.                 dungeon terrain type               on-screen symbol-               floor                              .+               ground                             .                corridor                           #                wall (horizontal and vertical)     - and |                rock or tree                       O@@ -42,58 +69,75 @@                bedrock                            blank  The game world is persistent, i.e., every time the player visits a level-during a single game, the level layout is the same.+during a single game, its layout is the same.  -Keys-----+Commands+-------- -You move throughout the level using the numerical keypad or-the vi text editor keys (also known as "Rogue-like keys").+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). -                7 8 9          y k u-                 \|/            \|/-                4-5-6          h-.-l-                 /|\            /|\-                1 2 3          b j n+                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 +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` and `.` keys consume a turn and make you brace for combat,-which confers a chance to block blows for the remainder of the turn.-In targeting mode the same keys move the targeting cursor.+The '5', '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). -Melee, searching for secret doors and opening closed doors+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 are necessary for casual play.-Some are provided only as building blocks for more complex convenience-commands, e.g., the autoexplore command (key `X`) could be defined-by the player as a macro using `BACKSPACE`, `CTRL-?`, `CTRL-;` and `P`.+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,+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 movement and terrain alteration.+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-                CTRL-;         make one step towards the target-                ;              go to target for 100 steps+                ;              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-                o              open door -Inventory and items-related keys are as follows.+Item-use related keys are as follows.                  keys           command-                I              display inventory-                g and ,        get an object-                d              drop an object+                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 @@ -101,13 +145,13 @@ you need to set your target first (however, initial target is set automatically as soon as a monster comes into view). Once in targeting mode, you can move the targeting cursor with arrow keys and switch focus-among enemies with `*` (or among friends and enemies, depending+among enemies with `*` (or among friends, projectiles and enemies, depending on targeting mode set by `/`). The details of the shared cursor position and of the personal target are described at the bottom of the screen. All targeting keys are listed below.                  keys           command-                *              target enemy+                KEYPAD_* and \ target enemy                 /              cycle targeting mode                 +              swerve targeting line                 -              unswerve targeting line@@ -117,88 +161,100 @@                 CTRL-{         target the closest stairs up                 CTRL-}         target the closest stairs down +Here are the commands for automating the actions of one or more members+of the team.++                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-A         automate faction (ESC to retake control)+ Assorted remaining keys and commands follow.                  keys           command                 ?              display help                 D              display player diary                 T              mark suspect terrain-                V              mark visible area-                S              mark smell+                Z              mark visible zone+                C              mark smell clues                 TAB            cycle among party members on the level-                SHIFT-TAB      cycle among party members in the dungeon-                =              select (or deselect) a party member-                _              deselect (or select) all on the level-                p              play back last keys-                P              play back last keys 100 times-                CTRL-p         play back last keys 1000 times-                '              start recording a macro+                SHIFT-TAB      cycle among all party members                 SPACE          clear messages-                ESC            cancel action+                ESC            cancel action, open Main Menu                 RET            accept choice-                0--9           pick a new hero leader anywhere in the dungeon+                0--6           pick a new hero leader anywhere in the dungeon  Commands for saving and exiting the current game, starting a new game, etc., are listed in the Main Menu, brought up by the `ESC` key.-All but the campaign and skirmish game modes are experimental-and feature multiple human or computer players (allied or not). Game difficulty setting affects hitpoints at birth for any actors-of any UI-using faction.+of any UI-using faction. For a person new to roguelikes, the Duel game mode+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-r         new campaign game-                CTRL-k         new skirmish game-                CTRL-v         new PvP game-                CTRL-o         new Coop game-                CTRL-e         new defense game+                CTRL-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  There are also some debug, testing and cheat options and game modes that can be specified on the command line when starting the game server.-Use at your own peril! :) Of these, you may find the screensaver modes+Use at your own peril! :) Of these, you may find the screensaver game modes the least spoilery and the most fun, e.g.: -    LambdaHack --newGame --noMore --maxFps 45 --savePrefix test --gameMode testCampaign --difficulty 1+    LambdaHack --savePrefix test --newGame --noMore --maxFps 60 --automateAll --gameMode campaign --difficulty 1 +The `--automateAll` option strictly corresponds to the `CTRL-A` command,+but most of the debug options have no corresponding commands. + Monsters -------- -Heroes are not alone in the dungeon. Monsters roam the dark caves-and crawl from damp holes day and night. While heroes pay attention-to all other party members and take care to move one at a time,-monsters don't care about each other and all move at once,-sometimes brutally colliding by accident.+Heroes are not alone in the dungeon. Monstrosities, natural+and out of this world, roam the dark caves and crawl from damp holes+day and night. While heroes pay attention to all other party members+and take care to move one at a time, monsters don't care about each other+and all move at once, sometimes brutally colliding by accident.  When the hero bumps into a monster or a monster attacks the hero,-melee combat occurs. The best weapon carried by each opponent-is taken into account for calculating bonus damage. The total damage-the current hero can potentially inflict is displayed at the bottom-of the screen. The total damage potential of a monster may change-as it finds and picks up new weapons. Heroes and monsters running into-one another (with the `SHIFT` key) do not inflict damage, but change places.+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+(with the `SHIFT` key) do not inflict damage, but change places. This gives the opponent a free blow, but can improve the tactical situation or aid escape. -Throwing weapons at targets wounds them, consuming the weapon in the process.-You may throw any object in your possession (press `?` to choose-an object and press it again for a non-standard choice) or on the floor-(press `-`). Only objects of a few kinds inflict any damage.+Slinging 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 choose an item 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.+When the last hero dies, the game ends in defeat.   On Winning and Dying -------------------- -You win the game if you escape the dungeon alive (or eliminate-all opposition, in some game modes). Your score is-the sum of all gold you've plundered plus 100 gold pieces for each gem.-Only the loot in possession of the party members on the current level-counts (the rest of the party is considered MIA).+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. -If all heroes die, your score is halved and only the treasure carried-by the last standing hero counts. You are free to start again-from a different entrance to the dungeon, but all your previous wealth-is gone and fresh, undaunted enemies bar your way.+If all your heroes fall, you are awarded a score for your valiant deeds,+but no winning bonus. When, invariably, a new overconfident 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.
+ GameDefinition/TieKnot.hs view
@@ -0,0 +1,38 @@+-- | Here the knot of engine code pieces and the game-specific+-- content definitions is tied, resulting in an executable game.+module TieKnot ( tieKnot ) where++import qualified Client.UI.Content.KeyKind as Content.KeyKind+import qualified Content.CaveKind+import qualified Content.FactionKind+import qualified Content.ItemKind+import qualified Content.ModeKind+import qualified Content.PlaceKind+import qualified Content.RuleKind+import qualified Content.TileKind+import Game.LambdaHack.Client (exeFrontend)+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)++-- | Tie the LambdaHack engine client, server and frontend code+-- with the game-specific content definitions, and run the game.+tieKnot :: [String] -> IO ()+tieKnot args =+  let -- Common content operations, created from content definitions.+      copsServer = Kind.COps+        { cocave    = Kind.createOps Content.CaveKind.cdefs+        , cofaction = Kind.createOps Content.FactionKind.cdefs+        , coitem    = Kind.createOps Content.ItemKind.cdefs+        , comode    = Kind.createOps Content.ModeKind.cdefs+        , coplace   = Kind.createOps Content.PlaceKind.cdefs+        , corule    = Kind.createOps Content.RuleKind.cdefs+        , cotile    = Kind.createOps Content.TileKind.cdefs+        }+      -- 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
GameDefinition/config.ui.default view
@@ -5,19 +5,21 @@ ; ; Warning: options are case-sensitive and only ';' for comments is permitted.  ; [extra_commands]-; ; Handy shorthands with Vi keys:-; Macro_1 = ("comma", (CmdItem, Macro "" ["g"]))-; Macro_2 = ("period", (CmdMove, Macro "" ["KP_Begin"]))+; ; A handy shorthand with Vi keys:+; Macro_1 = ("comma", ([CmdItem], Macro "" ["g"]))  ; [hero_names]-; HeroName_0 = Haskell Alvin-; HeroName_1 = Alonzo Barkley-; HeroName_2 = Ines Galenti-; HeroName_3 = Ernst Abraham-; HeroName_4 = Samuel Saunders-; HeroName_5 = Roger Robin+; 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 ; font = "Terminus,Monospace normal normal normal normal 12" ; historyMax = 5000 ; maxFps = 15
GameDefinition/scores view

binary file changed (188 → 701 bytes)

+ GameDefinition/screenshot.png view

binary file changed (absent → 13391 bytes)

LambdaHack.cabal view
@@ -1,10 +1,13 @@ name:          LambdaHack-version:       0.2.12-synopsis:      A roguelike game engine in early and active development+version:       0.2.14+synopsis:      A roguelike game engine in early development description:   This is an alpha release of LambdaHack,                a game engine library for roguelike games                of arbitrary theme, size and complexity,                packaged together with a small example dungeon crawler.+               .+               <<GameDefinition/screenshot.png>>+               .                When completed, the engine will let you specify content                to be procedurally generated, define the AI behaviour                on top of the generic content-independent rules@@ -36,15 +39,16 @@                inside the library --- users are free to do whatever they                please, since the library authors are in no position to guess                their particular needs.-homepage:      http://github.com/kosmikus/LambdaHack-bug-reports:   http://github.com/kosmikus/LambdaHack/issues+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 data-files:    GameDefinition/config.ui.default,                GameDefinition/scores extra-source-files: GameDefinition/PLAYING.md, GameDefinition/MainMenu.ascii,-                    README.md, LICENSE, CREDITS, changelog, Makefile+                    README.md, LICENSE, CREDITS, CHANGELOG.md, Makefile+extra-doc-files: GameDefinition/screenshot.png author:        Andres Loeh, Mikolaj Konarski maintainer:    Mikolaj Konarski <mikolaj.konarski@funktory.com> category:      Game Engine, Game@@ -53,69 +57,99 @@  source-repository head   type:               git-  location:           git://github.com/kosmikus/LambdaHack.git+  location:           git://github.com/LambdaHack/LambdaHack.git  flag vty-  description:        enable the vty frontend+  description:        switch to the vty frontend   default:            False  flag curses-  description:        enable the curses frontend+  description:        switch to the curses frontend (not fully supported)   default:            False  library-  exposed-modules:    Game.LambdaHack.Client,-                      Game.LambdaHack.Client.Action,-                      Game.LambdaHack.Client.Action.ActionClass,-                      Game.LambdaHack.Client.Action.ActionType,-                      Game.LambdaHack.Client.AtomicSemCli,-                      Game.LambdaHack.Client.Binding,-                      Game.LambdaHack.Client.ClientSem,-                      Game.LambdaHack.Client.Config,-                      Game.LambdaHack.Client.Draw,-                      Game.LambdaHack.Client.HumanGlobal,-                      Game.LambdaHack.Client.HumanLocal,-                      Game.LambdaHack.Client.HumanSem,-                      Game.LambdaHack.Client.LoopAction,-                      Game.LambdaHack.Client.RunAction,+  exposed-modules:    Game.LambdaHack.Atomic+                      Game.LambdaHack.Atomic.CmdAtomic,+                      Game.LambdaHack.Atomic.BroadcastAtomicWrite,+                      Game.LambdaHack.Atomic.HandleAtomicWrite,+                      Game.LambdaHack.Atomic.MonadAtomic,+                      Game.LambdaHack.Atomic.MonadStateWrite,+                      Game.LambdaHack.Atomic.PosAtomicRead,+                      Game.LambdaHack.Client,+                      Game.LambdaHack.Client.AI+                      Game.LambdaHack.Client.AI.ConditionClient,+                      Game.LambdaHack.Client.AI.HandleAbilityClient,+                      Game.LambdaHack.Client.AI.PickActorClient+                      Game.LambdaHack.Client.AI.PickTargetClient+                      Game.LambdaHack.Client.AI.Preferences+                      Game.LambdaHack.Client.AI.Strategy,+                      Game.LambdaHack.Client.Bfs,+                      Game.LambdaHack.Client.BfsClient,+                      Game.LambdaHack.Client.CommonClient,+                      Game.LambdaHack.Client.HandleAtomicClient,+                      Game.LambdaHack.Client.HandleResponseClient,+                      Game.LambdaHack.Client.ItemSlot,+                      Game.LambdaHack.Client.Key,+                      Game.LambdaHack.Client.LoopClient,+                      Game.LambdaHack.Client.MonadClient,+                      Game.LambdaHack.Client.ProtocolClient,                       Game.LambdaHack.Client.State,-                      Game.LambdaHack.Client.Strategy,-                      Game.LambdaHack.Client.StrategyAction,+                      Game.LambdaHack.Client.UI,+                      Game.LambdaHack.Client.UI.Animation,+                      Game.LambdaHack.Client.UI.Config,+                      Game.LambdaHack.Client.UI.Content.KeyKind+                      Game.LambdaHack.Client.UI.DrawClient,+                      Game.LambdaHack.Client.UI.DisplayAtomicClient,+                      Game.LambdaHack.Client.UI.Frontend,+                      Game.LambdaHack.Client.UI.Frontend.Chosen,+                      Game.LambdaHack.Client.UI.Frontend.Std,+                      Game.LambdaHack.Client.UI.HandleHumanGlobalClient,+                      Game.LambdaHack.Client.UI.HandleHumanLocalClient,+                      Game.LambdaHack.Client.UI.HandleHumanClient,+                      Game.LambdaHack.Client.UI.HumanCmd,+                      Game.LambdaHack.Client.UI.InventoryClient,+                      Game.LambdaHack.Client.UI.KeyBindings,+                      Game.LambdaHack.Client.UI.MonadClientUI,+                      Game.LambdaHack.Client.UI.MsgClient,+                      Game.LambdaHack.Client.UI.RunClient,+                      Game.LambdaHack.Client.UI.StartupFrontendClient+                      Game.LambdaHack.Client.UI.WidgetClient,                       Game.LambdaHack.Common.Ability,-                      Game.LambdaHack.Common.Action,                       Game.LambdaHack.Common.Actor,                       Game.LambdaHack.Common.ActorState,-                      Game.LambdaHack.Common.Animation,-                      Game.LambdaHack.Common.AtomicCmd,-                      Game.LambdaHack.Common.AtomicPos,-                      Game.LambdaHack.Common.AtomicSem,-                      Game.LambdaHack.Common.ClientCmd,+                      Game.LambdaHack.Common.ClientOptions,                       Game.LambdaHack.Common.Color,                       Game.LambdaHack.Common.ContentDef,+                      Game.LambdaHack.Common.Dice,                       Game.LambdaHack.Common.Effect,+                      Game.LambdaHack.Common.EffectDescription,                       Game.LambdaHack.Common.Faction,                       Game.LambdaHack.Common.Feature,+                      Game.LambdaHack.Common.File,                       Game.LambdaHack.Common.Flavour,+                      Game.LambdaHack.Common.Frequency,                       Game.LambdaHack.Common.HighScore,-                      Game.LambdaHack.Common.HumanCmd,                       Game.LambdaHack.Common.Item,-                      Game.LambdaHack.Common.ItemFeature,-                      Game.LambdaHack.Common.Key,+                      Game.LambdaHack.Common.ItemDescription,+                      Game.LambdaHack.Common.ItemStrongest,                       Game.LambdaHack.Common.Kind,                       Game.LambdaHack.Common.Level,+                      Game.LambdaHack.Common.LQueue,                       Game.LambdaHack.Common.Misc,+                      Game.LambdaHack.Common.MonadStateRead,                       Game.LambdaHack.Common.Msg,                       Game.LambdaHack.Common.Perception,                       Game.LambdaHack.Common.PointArray,                       Game.LambdaHack.Common.Point,                       Game.LambdaHack.Common.Random,                       Game.LambdaHack.Common.Save,-                      Game.LambdaHack.Common.ServerCmd,+                      Game.LambdaHack.Common.Request,+                      Game.LambdaHack.Common.Response,                       Game.LambdaHack.Common.State,+                      Game.LambdaHack.Common.Thread,                       Game.LambdaHack.Common.Tile,                       Game.LambdaHack.Common.Time,                       Game.LambdaHack.Common.Vector,-                      Game.LambdaHack.Content.ActorKind,                       Game.LambdaHack.Content.CaveKind,                       Game.LambdaHack.Content.FactionKind,                       Game.LambdaHack.Content.ItemKind,@@ -123,36 +157,37 @@                       Game.LambdaHack.Content.PlaceKind,                       Game.LambdaHack.Content.RuleKind,                       Game.LambdaHack.Content.TileKind,-                      Game.LambdaHack.Frontend,-                      Game.LambdaHack.Frontend.Chosen,-                      Game.LambdaHack.Frontend.Std,+                      Game.LambdaHack.SampleImplementation.SampleMonadClient,+                      Game.LambdaHack.SampleImplementation.SampleMonadServer,                       Game.LambdaHack.Server,-                      Game.LambdaHack.Server.Action,-                      Game.LambdaHack.Server.Action.ActionClass,-                      Game.LambdaHack.Server.Action.ActionType,-                      Game.LambdaHack.Server.AtomicSemSer,+                      Game.LambdaHack.Server.Commandline,+                      Game.LambdaHack.Server.CommonServer,+                      Game.LambdaHack.Server.DebugServer,                       Game.LambdaHack.Server.DungeonGen,-                      Game.LambdaHack.Server.DungeonGen.Area+                      Game.LambdaHack.Server.DungeonGen.Area,                       Game.LambdaHack.Server.DungeonGen.AreaRnd,                       Game.LambdaHack.Server.DungeonGen.Cave,                       Game.LambdaHack.Server.DungeonGen.Place,-                      Game.LambdaHack.Server.EffectSem,+                      Game.LambdaHack.Server.EndServer,                       Game.LambdaHack.Server.Fov,                       Game.LambdaHack.Server.Fov.Common,                       Game.LambdaHack.Server.Fov.Digital,                       Game.LambdaHack.Server.Fov.Permissive,                       Game.LambdaHack.Server.Fov.Shadow,-                      Game.LambdaHack.Server.LoopAction,-                      Game.LambdaHack.Server.ServerSem,-                      Game.LambdaHack.Server.StartAction,-                      Game.LambdaHack.Server.State,-                      Game.LambdaHack.Utils.File,-                      Game.LambdaHack.Utils.Frequency,-                      Game.LambdaHack.Utils.LQueue,-                      Game.LambdaHack.Utils.Thread+                      Game.LambdaHack.Server.HandleEffectServer,+                      Game.LambdaHack.Server.HandleRequestServer,+                      Game.LambdaHack.Server.ItemRev,+                      Game.LambdaHack.Server.ItemServer,+                      Game.LambdaHack.Server.LoopServer,+                      Game.LambdaHack.Server.MonadServer,+                      Game.LambdaHack.Server.PeriodicServer,+                      Game.LambdaHack.Server.ProtocolServer,+                      Game.LambdaHack.Server.StartServer,+                      Game.LambdaHack.Server.State   other-modules:      Paths_LambdaHack   build-depends:      array      >= 0.3.0.3 && < 1,                       assert-failure >= 0.1 && < 1,+                      async      >= 2       && < 3,                       base       >= 4       && < 5,                       binary     >= 0.7     && < 1,                       bytestring >= 0.9.2   && < 1,@@ -185,7 +220,9 @@                       TypeFamilies, FlexibleContexts, FlexibleInstances,                       DeriveFunctor, FunctionalDependencies,                       GeneralizedNewtypeDeriving, TupleSections,-                      DeriveFoldable, DeriveTraversable+                      DeriveFoldable, DeriveTraversable,+                      ExistentialQuantification, GADTs, StandaloneDeriving,+                      DataKinds, KindSignatures --, DeriveGeneric   ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas   ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude@@ -193,35 +230,40 @@   ghc-prof-options:   -fprof-auto-calls    if flag(curses) {-    other-modules:    Game.LambdaHack.Frontend.Curses+    other-modules:    Game.LambdaHack.Client.UI.Frontend.Curses     build-depends:    hscurses >= 1.4.1 && < 2     cpp-options:      -DCURSES   } else { if flag(vty) {-    other-modules:    Game.LambdaHack.Frontend.Vty+    other-modules:    Game.LambdaHack.Client.UI.Frontend.Vty     build-depends:    vty >= 4.7.0.6 && < 5     cpp-options:      -DVTY   } else {-    other-modules:    Game.LambdaHack.Frontend.Gtk+    other-modules:    Game.LambdaHack.Client.UI.Frontend.Gtk     build-depends:    gtk >= 0.12.1 && < 0.13   } }  executable LambdaHack   hs-source-dirs:     GameDefinition   main-is:            Main.hs-  other-modules:      Content.ActorKind,+  other-modules:      Client.UI.Content.KeyKind,                       Content.CaveKind,                       Content.FactionKind,                       Content.ItemKind,+                      Content.ItemKindActor,+                      Content.ItemKindOrgan,+                      Content.ItemKindShrapnel,                       Content.ModeKind,                       Content.PlaceKind,                       Content.RuleKind,                       Content.TileKind,+                      TieKnot,                       Paths_LambdaHack   build-depends:      LambdaHack,                       template-haskell >= 2.6 && < 3,                        array      >= 0.3.0.3 && < 1,                       assert-failure >= 0.1 && < 1,+                      async      >= 2       && < 3,                       base       >= 4       && < 5,                       binary     >= 0.7     && < 1,                       bytestring >= 0.9.2   && < 1,@@ -254,5 +296,49 @@   ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas   ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude   ghc-options:        -fno-ignore-asserts -funbox-strict-fields-  ghc-options:        -threaded -with-rtsopts=-C0.005+  ghc-options:        -threaded -with-rtsopts=-C0.005 -rtsopts -- ghc-options:       -with-rtsopts=-N  -- eats all cores++test-suite test+  type:               exitcode-stdio-1.0+  hs-source-dirs:     GameDefinition, test+  main-is:            test.hs+  build-depends:      LambdaHack,+                      template-haskell >= 2.6 && < 3,++                      array      >= 0.3.0.3 && < 1,+                      assert-failure >= 0.1 && < 1,+                      async      >= 2       && < 3,+                      base       >= 4       && < 5,+                      binary     >= 0.7     && < 1,+                      bytestring >= 0.9.2   && < 1,+                      containers >= 0.5     && < 1,+                      deepseq    >= 1.3     && < 2,+                      directory  >= 1.1.0.1 && < 2,+                      enummapset-th >= 0.6.0.0 && < 1,+                      filepath   >= 1.2.0.1 && < 2,+                      ghc-prim   >= 0.2,+                      hashable   >= 1.1.2.5 && < 2,+                      hsini      >= 0.2     && < 2,+                      keys       >= 3       && < 4,+                      miniutter  >= 0.4.1   && < 2,+                      mtl        >= 2.0.1   && < 3,+                      old-time   >= 1.0.0.7 && < 2,+                      pretty-show >= 1.6    && < 2,+                      random     >= 1.0.1   && < 2,+                      stm        >= 2.4     && < 3,+                      text       >= 0.11.2.3 && < 2,+                      transformers >= 0.3   && < 1,+                      unordered-containers >= 0.2.3 && < 1,+                      vector     >= 0.10    && < 1,+                      vector-binary-instances >= 0.2 && < 1,+                      zlib       >= 0.5.3.1 && < 1++  default-language:   Haskell2010+  default-extensions: MonoLocalBinds, ScopedTypeVariables, OverloadedStrings+                      BangPatterns, RecordWildCards, NamedFieldPuns+  other-extensions:   TemplateHaskell+  ghc-options:        -Wall -fwarn-orphans -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unrecognised-pragmas+  ghc-options:        -fno-warn-auto-orphans -fno-warn-implicit-prelude+  ghc-options:        -fno-ignore-asserts -funbox-strict-fields+  ghc-options:        -threaded -with-rtsopts=-C0.005 -rtsopts
Makefile view
@@ -9,229 +9,245 @@   xcplay:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer--xcpeekCampaign:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign--xcpeekSkirmish:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --dumpInitRngs  xcfrontendCampaign:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testCampaign --difficulty 1+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode campaign --difficulty 1  xcfrontendSkirmish:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testSkirmish+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode skirmish -xcfrontendBattle:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testBattle --difficulty 1+xcfrontendAmbush:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode ambush -xcfrontendPvP:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testPvP --fovMode Shadow+xcfrontendBattle:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode battle --difficulty 1 -xcfrontendCoop:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testCoop --difficulty 1 --fovMode Permissive+xcfrontendSafari:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode safari --difficulty 1  xcfrontendDefense:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testDefense --difficulty 9+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode defense --difficulty 9  xcbenchCampaign:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendNo --benchmark --stopAfter 60 --gameMode testCampaign --difficulty 1 --setDungeonRng 42 --setMainRng 42+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --gameMode campaign --difficulty 1 --setDungeonRng 42 --setMainRng 42  xcbenchBattle:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendNo --benchmark --stopAfter 60 --gameMode testBattle --difficulty 1 --setDungeonRng 42 --setMainRng 42+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --gameMode battle --difficulty 1 --setDungeonRng 42 --setMainRng 42  xcbenchFrontendCampaign:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --benchmark --stopAfter 60 --gameMode testCampaign --difficulty 1 --setDungeonRng 42 --setMainRng 42+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 100000 --benchmark --stopAfter 60 --automateAll --gameMode campaign --difficulty 1 --setDungeonRng 42 --setMainRng 42  xcbenchFrontendBattle:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --benchmark --stopAfter 60 --gameMode testBattle --difficulty 1 --setDungeonRng 42 --setMainRng 42+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 100000 --benchmark --stopAfter 60 --automateAll --gameMode battle --difficulty 1 --setDungeonRng 42 --setMainRng 42 -xcbenchNo: xcbenchCampaign xcbenchBattle+xcbenchNull: xcbenchCampaign xcbenchBattle  xcbench: xcbenchCampaign xcbenchFrontendCampaign xcbenchBattle xcbenchFrontendBattle -xctest-travis: xctest-short xctest-medium xcbenchNo -xctest-travis-long: xctest-short xctest-long xcbenchNo+xctest-travis-short: xctest-short xcbenchNull +xctest-travis: xctest-short xctest-medium xcbenchNull++xctest-travis-long: xctest-short xctest-long xcbenchNull+ xctest: xctest-short xctest-medium xctest-long  xctest-short: xctest-short-new xctest-short-load -xctest-medium: xctestCampaign-medium xctestSkirmish-medium xctestBattle-medium xctestPvP-medium xctestCoop-medium xctestDefense-medium+xctest-medium: xctestCampaign-medium xctestSkirmish-medium xctestAmbush-medium xctestBattle-medium xctestSafari-medium xctestPvP-medium xctestCoop-medium xctestDefense-medium -xctest-long: xctestCampaign-long xctestCoop-long xctestDefense-long+xctest-long: xctestCampaign-long xctestSkirmish-long xctestAmbush-long xctestBattle-long xctestSafari-long xctestPvP-long xctestCoop-long xctestDefense-long  xctestCampaign-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testCampaign --difficulty 1 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode campaign --difficulty 1 > /tmp/stdtest.log  xctestCampaign-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testCampaign --difficulty 1 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode campaign --difficulty 1 > /tmp/stdtest.log  xctestSkirmish-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testSkirmish > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode skirmish > /tmp/stdtest.log  xctestSkirmish-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testSkirmish > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --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 --noMore --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 --noMore --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 --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testBattle --difficulty 1 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode battle --difficulty 1 > /tmp/stdtest.log  xctestBattle-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testBattle --difficulty 1 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 150 --dumpInitRngs --automateAll --gameMode battle --difficulty 1 > /tmp/stdtest.log +xctestSafari-long:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode safari --difficulty 1 > /tmp/stdtest.log++xctestSafari-medium:+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode safari --difficulty 1 > /tmp/stdtest.log+ xctestPvP-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testPvP > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --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 --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testPvP > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --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 --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testCoop --difficulty 1 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode Coop --difficulty 1 > /tmp/stdtest.log  xctestCoop-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testCoop --difficulty 1 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode Coop --difficulty 1 > /tmp/stdtest.log  xctestDefense-long:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testDefense --difficulty 9 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode defense --difficulty 9 > /tmp/stdtest.log  xctestDefense-medium:-	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testDefense --difficulty 9 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode defense --difficulty 9 > /tmp/stdtest.log  xctest-short-new:-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix campaign --dumpInitRngs --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix skirmish --dumpInitRngs --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix battle --dumpInitRngs --gameMode battle --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix PvP --dumpInitRngs --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix Coop --dumpInitRngs --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix defense --dumpInitRngs --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix campaign --dumpInitRngs --automateAll --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix skirmish --dumpInitRngs --automateAll --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix ambush --dumpInitRngs --automateAll --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix battle --dumpInitRngs --automateAll --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix safari --dumpInitRngs --automateAll --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix PvP --dumpInitRngs --automateAll --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix Coop --dumpInitRngs --automateAll --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --newGame --noMore --savePrefix defense --dumpInitRngs --automateAll --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log  xctest-short-load:-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix campaign --dumpInitRngs --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix skirmish --dumpInitRngs --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix battle --dumpInitRngs --gameMode battle --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix PvP --dumpInitRngs --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix Coop --dumpInitRngs --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix defense --dumpInitRngs --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix campaign --dumpInitRngs --automateAll --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix skirmish --dumpInitRngs --automateAll --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix ambush --dumpInitRngs --automateAll --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix battle --dumpInitRngs --automateAll --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix safari --dumpInitRngs --automateAll --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix PvP --dumpInitRngs --automateAll --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix Coop --dumpInitRngs --automateAll --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack +RTS -xc -RTS --dbgMsgSer --noMore --savePrefix defense --dumpInitRngs --automateAll --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log   play:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer--peekCampaign:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign--peekSkirmish:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --dumpInitRngs  frontendCampaign:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testCampaign --difficulty 1+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode campaign --difficulty 1  frontendSkirmish:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testSkirmish+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode skirmish -frontendBattle:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testBattle --difficulty 1+frontendAmbush:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode ambush -frontendPvP:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testPvP --fovMode Shadow+frontendBattle:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode battle --difficulty 1 -frontendCoop:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testCoop --difficulty 1 --fovMode Permissive+frontendSafari:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode safari --difficulty 1  frontendDefense:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 180 --savePrefix test --dumpInitRngs --gameMode testDefense --difficulty 9+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 60 --dumpInitRngs --automateAll --gameMode defense --difficulty 9  benchCampaign:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendNo --benchmark --stopAfter 60 --gameMode testCampaign --difficulty 1 --setDungeonRng 42 --setMainRng 42+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --gameMode campaign --difficulty 1 --setDungeonRng 42 --setMainRng 42  benchBattle:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendNo --benchmark --stopAfter 60 --gameMode testBattle --difficulty 1 --setDungeonRng 42 --setMainRng 42+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 60 --automateAll --gameMode battle --difficulty 1 --setDungeonRng 42 --setMainRng 42  benchFrontendCampaign:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --benchmark --stopAfter 60 --gameMode testCampaign --difficulty 1 --setDungeonRng 42 --setMainRng 42+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 100000 --benchmark --stopAfter 60 --automateAll --gameMode campaign --difficulty 1 --setDungeonRng 42 --setMainRng 42  benchFrontendBattle:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --maxFps 100000 --savePrefix test --benchmark --stopAfter 60 --gameMode testBattle --difficulty 1 --setDungeonRng 42 --setMainRng 42+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 100000 --benchmark --stopAfter 60 --automateAll --gameMode battle --difficulty 1 --setDungeonRng 42 --setMainRng 42 -benchNo: benchCampaign benchBattle+benchNull: benchCampaign benchBattle  bench: benchCampaign benchFrontendCampaign benchBattle benchFrontendBattle  -test-travis: test-short test-medium benchNo+test-travis-short: test-short benchNull -test-travis-long: test-short test-long benchNo+test-travis: test-short test-medium benchNull +test-travis-long: test-short test-long benchNull+ test: test-short test-medium test-long  test-short: test-short-new test-short-load -test-medium: testCampaign-medium testSkirmish-medium testBattle-medium testPvP-medium testCoop-medium testDefense-medium+test-medium: testCampaign-medium testSkirmish-medium testAmbush-medium testBattle-medium testSafari-medium testPvP-medium testCoop-medium testDefense-medium -test-long: testCampaign-long testCoop-long testDefense-long+test-long: testCampaign-long testSkirmish-long testAmbush-long testBattle-long testSafari-long testPvP-long testCoop-long testDefense-long  testCampaign-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testCampaign --difficulty 1 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode campaign --difficulty 1 > /tmp/stdtest.log  testCampaign-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testCampaign --difficulty 1 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode campaign --difficulty 1 > /tmp/stdtest.log  testSkirmish-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testSkirmish > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode skirmish > /tmp/stdtest.log  testSkirmish-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testSkirmish > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode skirmish > /tmp/stdtest.log +testAmbush-long:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode ambush > /tmp/stdtest.log++testAmbush-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode ambush > /tmp/stdtest.log+ testBattle-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testBattle --difficulty 1 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode battle --difficulty 1 > /tmp/stdtest.log  testBattle-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testBattle --difficulty 1 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 150 --dumpInitRngs --automateAll --gameMode battle --difficulty 1 > /tmp/stdtest.log +testSafari-long:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode safari --difficulty 1 > /tmp/stdtest.log++testSafari-medium:+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode safari --difficulty 1 > /tmp/stdtest.log+ testPvP-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testPvP > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 60 --dumpInitRngs --automateAll --gameMode PvP > /tmp/stdtest.log  testPvP-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testPvP > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 30 --dumpInitRngs --automateAll --gameMode PvP > /tmp/stdtest.log  testCoop-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testCoop --difficulty 1 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode Coop --difficulty 1 > /tmp/stdtest.log  testCoop-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testCoop --difficulty 1 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode Coop --difficulty 1 > /tmp/stdtest.log  testDefense-long:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 580 --dumpInitRngs --gameMode testDefense --difficulty 9 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 400 --dumpInitRngs --automateAll --gameMode defense --difficulty 9 > /tmp/stdtest.log  testDefense-medium:-	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --noDelay --noAnim --maxFps 100000 --savePrefix test --frontendStd --benchmark --stopAfter 280 --dumpInitRngs --gameMode testDefense --difficulty 9 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendStd --benchmark --stopAfter 250 --dumpInitRngs --automateAll --gameMode defense --difficulty 9 > /tmp/stdtest.log  test-short-new:-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix campaign --dumpInitRngs --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix skirmish --dumpInitRngs --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix battle --dumpInitRngs --gameMode battle --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix PvP --dumpInitRngs --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix Coop --dumpInitRngs --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix defense --dumpInitRngs --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix campaign --dumpInitRngs --automateAll --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix skirmish --dumpInitRngs --automateAll --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix ambush --dumpInitRngs --automateAll --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix battle --dumpInitRngs --automateAll --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix safari --dumpInitRngs --automateAll --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix PvP --dumpInitRngs --automateAll --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix Coop --dumpInitRngs --automateAll --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --newGame --noMore --savePrefix defense --dumpInitRngs --automateAll --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log  test-short-load:-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix campaign --dumpInitRngs --gameMode campaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix skirmish --dumpInitRngs --gameMode skirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix battle --dumpInitRngs --gameMode battle --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix PvP --dumpInitRngs --gameMode PvP --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix Coop --dumpInitRngs --gameMode Coop --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix defense --dumpInitRngs --gameMode defense --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekCampaign --dumpInitRngs --gameMode peekCampaign --frontendStd --stopAfter 0 > /tmp/stdtest.log-	while true; do echo ' '; echo '.'; sleep 1; done | dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix peekSkirmish --dumpInitRngs --gameMode peekSkirmish --frontendStd --stopAfter 0 > /tmp/stdtest.log-+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix campaign --dumpInitRngs --automateAll --gameMode campaign --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix skirmish --dumpInitRngs --automateAll --gameMode skirmish --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix ambush --dumpInitRngs --automateAll --gameMode ambush --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix battle --dumpInitRngs --automateAll --gameMode battle --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix safari --dumpInitRngs --automateAll --gameMode safari --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix PvP --dumpInitRngs --automateAll --gameMode PvP --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix Coop --dumpInitRngs --automateAll --gameMode Coop --frontendStd --stopAfter 2 > /tmp/stdtest.log+	dist/build/LambdaHack/LambdaHack --dbgMsgSer --noMore --savePrefix defense --dumpInitRngs --automateAll --gameMode defense --frontendStd --stopAfter 2 > /tmp/stdtest.log   # The rest of the makefile is unmaintained at the moment.
README.md view
@@ -1,4 +1,4 @@-LambdaHack [![Build Status](https://secure.travis-ci.org/kosmikus/LambdaHack.png)](http://travis-ci.org/kosmikus/LambdaHack)[![Build Status](https://drone.io/github.com/kosmikus/LambdaHack/status.png)](https://drone.io/github.com/kosmikus/LambdaHack/latest)+LambdaHack [![Build Status](https://secure.travis-ci.org/LambdaHack/LambdaHack.png)](http://travis-ci.org/LambdaHack/LambdaHack)[![Build Status](https://drone.io/github.com/LambdaHack/LambdaHack/status.png)](https://drone.io/github.com/LambdaHack/LambdaHack/latest) ==========  This is an alpha release of LambdaHack, a [Haskell] [1] game engine@@ -16,9 +16,10 @@ auto-balancing and persistent content modification based on player behaviour.  The engine comes with a sample code for a little dungeon crawler,-called LambdaHack and described in `PLAYING.md`. The engine and the example-game are bundled together in a single [Hackage] [3] package.-You are welcome to create your own games by modifying the sample game+called LambdaHack and described in [PLAYING.md](GameDefinition/PLAYING.md).+The engine and the example game are bundled together+in a single [Hackage] [3] package. You are welcome+to create your own games by modifying the sample game and the engine code, but please consider eventually splitting your changes into a separate Hackage package that depends on the upstream library, to help us exchange ideas and share improvements to the common code.@@ -26,6 +27,7 @@ Games known to use the LambdaHack library:  * [Allure of the Stars] [6], a near-future Sci-Fi game in early development+* [Space Privateers] [8], an adventure game set in far future   Compilation and installation@@ -54,53 +56,56 @@ Compatibility notes ------------------- -The current code was tested with GHC 7.6 and 7.8, but should also work with-other GHC versions (see file `.travis.yml.7.4.2` for GHC 7.4 commands).+The current code was tested with GHC 7.6 and 7.8,+but should also work with other GHC versions.  If you are using the terminal frontends, numerical keypad may not work correctly depending on versions of the libraries, terminfo and terminal emulators. The curses frontend is not fully supported due to the limitations of the curses library. With the vty frontend run in an xterm, CTRL-keypad keys for running seem to work OK, but on rxvt they do not.-Vi keys (ykuhlbjn) should work everywhere regardless. GTK works fine, too.+Laptop (uk8o79jl) and Vi keys (hjklyubn, if enabled in config.ui.ini)+should work everywhere regardless. GTK works fine, too.   Testing and debugging --------------------- -The `Makefile` contains many sample test commands. All that use the screensaver-game modes (AI vs. AI) and the simplest stdout frontend are gathered-in `make test`. Of these, travis runs one of the sets prefixed-`test-travis` on each push to the repo. Commands with prefix-`frontend` run AI vs. AI games with the standard, user-friendly frontend.-Commands with prefix `peek` set up a game mode where the player peeks-into AI moves each time an AI actor dies or autosave kicks in.+The [Makefile](Makefile) contains many sample test commands.+All commands 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+with the standard, user-friendly frontend.+ Run `LambdaHack --help` to see a brief description of all debug options. Of these, `--sniffIn` and `--sniffOut` are very useful (though verbose and initially cryptic), for monitoring the traffic between clients-and the server. Some options in the config file may turn out useful too,+and the server. Some options in the config file may prove useful too, though they mostly overlap with commandline options (and will be totally merged at some point). -You can use HPC with the game as follows+You can use HPC with the game as follows (a quick manual playing session+after the automated tests would be in order, as well, since the tests don't+touch the topmost UI layer).      cabal clean     cabal install --enable-library-coverage     make test-    hpc report --hpcdir=dist/hpc/mix/LambdaHack-0.2.10.6/ LambdaHack-    hpc markup --hpcdir=dist/hpc/mix/LambdaHack-0.2.10.6/ LambdaHack+    hpc report --hpcdir=dist/hpc/mix/LambdaHack-0.2.14/ LambdaHack+    hpc markup --hpcdir=dist/hpc/mix/LambdaHack-0.2.14/ LambdaHack -The debug option `--stopAfter` is required for any screensaver mode-game invocations that gather HPC info, because HPC needs a clean exit-(to save data files) and screensaver modes can't be cleanly stopped-in any other way.+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).   Further information -------------------  For more information, visit the [wiki] [4]-and see `GameDefinition/PLAYING.md`, `CREDITS` and `LICENSE`.+and see [PLAYING.md](GameDefinition/PLAYING.md), [CREDITS](CREDITS)+and [LICENSE](LICENSE).  Have fun! @@ -109,7 +114,8 @@ [1]: http://www.haskell.org/ [2]: http://roguebasin.roguelikedevelopment.org/index.php?title=Berlin_Interpretation [3]: http://hackage.haskell.org/package/LambdaHack-[4]: https://github.com/kosmikus/LambdaHack/wiki-[5]: http://github.com/kosmikus/LambdaHack-[6]: http://hackage.haskell.org/package/Allure+[4]: https://github.com/LambdaHack/LambdaHack/wiki+[5]: http://github.com/LambdaHack/LambdaHack+[6]: http://allureofthestars.com [7]: http://www.haskell.org/platform+[8]: https://github.com/tuturto/space-privateers
− changelog 
@@ -1,55 +0,0 @@-v0.2.12--        * improve and simplify dungeon generation-        * simplify running and permit multi-actor runs-        * let items explode and generate shrapnel projectiles-        * add game difficulty setting (initial HP scaling right now)-        * allow recording, playing back and looping commands-        * implement pathfinding via per-actor BFS over the whole level-        * extend setting targets for actors in UI tremendously-        * implement autoexplore, go-to-target, etc., as macros-        * let AI use pathfinding, switch leaders, pick levels to swarm to-        * force level/leader changes on spawners (even when played by humans)-        * extend and redesign UI bottom status lines-        * get rid of CPS style monads, aborts and WriterT-        * benchmark and optimize the code, in particular using Data.Vector-        * split off and use the external library assert-failure-        * simplify config files and limit the number of external dependencies--v0.2.10--        * screensaver game modes (AI vs AI)-        * improved AI (can now climbs stairs, etc.)-        * multiple, multi-floor staircases-        * multiple savefiles-        * configurable framerate and combat animations--v0.2.8--        * cooperative and competitive multiplayer (shared-screen only in this version)-        * overhauled searching-        * rewritten engine code to have a single server that sends restricted game state updates to many fat clients, while a thin frontend layer multiplexes visuals from a subset of the clients--v0.2.6.5--        * this is a minor release, primarily intended to fix the broken haddock documentation on Hackage-        * changes since 0.2.6 are mostly unrelated to gameplay:-          - strictly typed config files split into UI and rules-          - a switch from Text to String throughout the codebase-          - use of the external library miniutter for English sentence generation--v0.2.6--        * the Main Menu-        * improved and configurable mode of squad combat--v0.2.1--        * missiles flying for three turns (by an old kosmikus' idea)-        * visual feedback for targeting-        * animations of combat and individual monster moves--v0.2.0--        * the LambdaHack engine becomes a Haskell library-        * the LambdaHack game depends on the engine library
+ test/test.hs view
@@ -0,0 +1,6 @@+import TieKnot++main :: IO ()+main = do+  tieKnot $ tail $ words "dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 6 --automateAll --gameMode campaign --difficulty 1 --setDungeonRng 42 --setMainRng 42"+  -- tieKnot $ tail $ words "dist/build/LambdaHack/LambdaHack --dbgMsgSer --savePrefix test --newGame --noMore --noDelay --noAnim --maxFps 100000 --frontendNull --benchmark --stopAfter 6 --automateAll --gameMode battle --difficulty 1 --setDungeonRng 42 --setMainRng 42"