LambdaHack 0.6.2.0 → 0.7.0.0

raw patch · 150 files changed

+7434/−6658 lines, 150 filesdep +optparse-applicativePVP ok

version bump matches the API change (PVP)

Dependencies added: optparse-applicative

API changes (from Hackage documentation)

Files

• CHANGELOG.md +19/−0
• CREDITS +1/−0
• Game/LambdaHack/Atomic.hs +7/−11
• Game/LambdaHack/Atomic/CmdAtomic.hs +40/−26
• Game/LambdaHack/Atomic/HandleAtomicWrite.hs +299/−138
• Game/LambdaHack/Atomic/MonadAtomic.hs +0/−20
• Game/LambdaHack/Atomic/MonadStateWrite.hs +125/−43
• Game/LambdaHack/Atomic/PosAtomicRead.hs +47/−54
• Game/LambdaHack/Client.hs +16/−3
• Game/LambdaHack/Client/AI.hs +26/−60
• Game/LambdaHack/Client/AI/ConditionM.hs +35/−36
• Game/LambdaHack/Client/AI/HandleAbilityM.hs +88/−73
• Game/LambdaHack/Client/AI/PickActorM.hs +24/−15
• Game/LambdaHack/Client/AI/PickTargetM.hs +54/−48
• Game/LambdaHack/Client/AI/Strategy.hs +13/−6
• Game/LambdaHack/Client/Bfs.hs +7/−6
• Game/LambdaHack/Client/BfsM.hs +34/−38
• Game/LambdaHack/Client/ClientOptions.hs +84/−0
• Game/LambdaHack/Client/CommonM.hs +32/−97
• Game/LambdaHack/Client/HandleAtomicM.hs +127/−348
• Game/LambdaHack/Client/HandleResponseM.hs +36/−17
• Game/LambdaHack/Client/LoopM.hs +57/−32
• Game/LambdaHack/Client/MonadClient.hs +8/−13
• Game/LambdaHack/Client/Preferences.hs +67/−48
• Game/LambdaHack/Client/Request.hs +67/−0
• Game/LambdaHack/Client/Response.hs +33/−0
• Game/LambdaHack/Client/State.hs +51/−66
• Game/LambdaHack/Client/UI.hs +48/−50
• Game/LambdaHack/Client/UI/ActorUI.hs +7/−8
• Game/LambdaHack/Client/UI/Animation.hs +13/−7
• Game/LambdaHack/Client/UI/Config.hs +0/−145
• Game/LambdaHack/Client/UI/Content/KeyKind.hs +13/−10
• Game/LambdaHack/Client/UI/DisplayAtomicM.hs +216/−184
• Game/LambdaHack/Client/UI/DrawM.hs +50/−57
• Game/LambdaHack/Client/UI/EffectDescription.hs +19/−14
• Game/LambdaHack/Client/UI/Frame.hs +44/−16
• Game/LambdaHack/Client/UI/FrameM.hs +46/−26
• Game/LambdaHack/Client/UI/Frontend.hs +48/−46
• Game/LambdaHack/Client/UI/Frontend/Chosen.hs +1/−1
• Game/LambdaHack/Client/UI/Frontend/Common.hs +8/−8
• Game/LambdaHack/Client/UI/Frontend/Curses.hs +10/−10
• Game/LambdaHack/Client/UI/Frontend/Dom.hs +19/−19
• Game/LambdaHack/Client/UI/Frontend/Gtk.hs +20/−24
• Game/LambdaHack/Client/UI/Frontend/Sdl.hs +27/−26
• Game/LambdaHack/Client/UI/Frontend/Teletype.hs +11/−15
• Game/LambdaHack/Client/UI/Frontend/Vty.hs +3/−3
• Game/LambdaHack/Client/UI/HandleHelperM.hs +77/−36
• Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs +84/−84
• Game/LambdaHack/Client/UI/HandleHumanLocalM.hs +81/−88
• Game/LambdaHack/Client/UI/HandleHumanM.hs +39/−13
• Game/LambdaHack/Client/UI/HumanCmd.hs +15/−26
• Game/LambdaHack/Client/UI/InventoryM.hs +31/−36
• Game/LambdaHack/Client/UI/ItemDescription.hs +116/−13
• Game/LambdaHack/Client/UI/ItemSlot.hs +16/−13
• Game/LambdaHack/Client/UI/Key.hs +36/−22
• Game/LambdaHack/Client/UI/KeyBindings.hs +20/−20
• Game/LambdaHack/Client/UI/MonadClientUI.hs +66/−59
• Game/LambdaHack/Client/UI/Msg.hs +14/−8
• Game/LambdaHack/Client/UI/MsgM.hs +26/−8
• Game/LambdaHack/Client/UI/Overlay.hs +29/−149
• Game/LambdaHack/Client/UI/OverlayM.hs +0/−85
• Game/LambdaHack/Client/UI/RunM.hs +20/−16
• Game/LambdaHack/Client/UI/SessionUI.hs +37/−34
• Game/LambdaHack/Client/UI/Slideshow.hs +15/−7
• Game/LambdaHack/Client/UI/SlideshowM.hs +18/−13
• Game/LambdaHack/Client/UI/UIOptions.hs +149/−0
• Game/LambdaHack/Common/Ability.hs +14/−14
• Game/LambdaHack/Common/Actor.hs +58/−61
• Game/LambdaHack/Common/ActorState.hs +60/−42
• Game/LambdaHack/Common/ClientOptions.hs +0/−82
• Game/LambdaHack/Common/Color.hs +73/−70
• Game/LambdaHack/Common/ContentDef.hs +6/−5
• Game/LambdaHack/Common/Dice.hs +164/−165
• Game/LambdaHack/Common/Faction.hs +28/−22
• Game/LambdaHack/Common/File.hs +1/−1
• Game/LambdaHack/Common/Flavour.hs +6/−2
• Game/LambdaHack/Common/Frequency.hs +36/−14
• Game/LambdaHack/Common/HSFile.hs +10/−6
• Game/LambdaHack/Common/HighScore.hs +50/−49
• Game/LambdaHack/Common/Item.hs +215/−193
• Game/LambdaHack/Common/ItemStrongest.hs +71/−67
• Game/LambdaHack/Common/JSFile.hs +7/−8
• Game/LambdaHack/Common/Kind.hs +27/−23
• Game/LambdaHack/Common/Level.hs +41/−17
• Game/LambdaHack/Common/Misc.hs +102/−99
• Game/LambdaHack/Common/MonadStateRead.hs +20/−16
• Game/LambdaHack/Common/Perception.hs +4/−7
• Game/LambdaHack/Common/Point.hs +4/−0
• Game/LambdaHack/Common/PointArray.hs +28/−25
• Game/LambdaHack/Common/Prelude.hs +2/−2
• Game/LambdaHack/Common/Random.hs +8/−12
• Game/LambdaHack/Common/ReqFailure.hs +211/−0
• Game/LambdaHack/Common/Request.hs +0/−259
• Game/LambdaHack/Common/Response.hs +0/−33
• Game/LambdaHack/Common/RingBuffer.hs +3/−3
• Game/LambdaHack/Common/Save.hs +14/−14
• Game/LambdaHack/Common/State.hs +159/−75
• Game/LambdaHack/Common/Tile.hs +111/−105
• Game/LambdaHack/Common/Time.hs +35/−31
• Game/LambdaHack/Common/Vector.hs +23/−18
• Game/LambdaHack/Content/CaveKind.hs +36/−34
• Game/LambdaHack/Content/ItemKind.hs +125/−84
• Game/LambdaHack/Content/ModeKind.hs +33/−28
• Game/LambdaHack/Content/RuleKind.hs +3/−9
• Game/LambdaHack/Content/TileKind.hs +41/−41
• Game/LambdaHack/SampleImplementation/SampleMonadClient.hs +37/−40
• Game/LambdaHack/SampleImplementation/SampleMonadServer.hs +82/−43
• Game/LambdaHack/Server.hs +10/−6
• Game/LambdaHack/Server/BroadcastAtomic.hs +140/−79
• Game/LambdaHack/Server/Commandline.hs +255/−157
• Game/LambdaHack/Server/CommonM.hs +147/−107
• Game/LambdaHack/Server/DebugM.hs +40/−30
• Game/LambdaHack/Server/DungeonGen.hs +26/−25
• Game/LambdaHack/Server/DungeonGen/Area.hs +19/−4
• Game/LambdaHack/Server/DungeonGen/AreaRnd.hs +5/−17
• Game/LambdaHack/Server/DungeonGen/Cave.hs +33/−30
• Game/LambdaHack/Server/DungeonGen/Place.hs +16/−12
• Game/LambdaHack/Server/EndM.hs +71/−11
• Game/LambdaHack/Server/Fov.hs +51/−81
• Game/LambdaHack/Server/FovDigital.hs +1/−1
• Game/LambdaHack/Server/HandleAtomicM.hs +89/−88
• Game/LambdaHack/Server/HandleEffectM.hs +203/−180
• Game/LambdaHack/Server/HandleRequestM.hs +180/−128
• Game/LambdaHack/Server/ItemM.hs +37/−49
• Game/LambdaHack/Server/ItemRev.hs +57/−55
• Game/LambdaHack/Server/LoopM.hs +86/−138
• Game/LambdaHack/Server/MonadServer.hs +56/−33
• Game/LambdaHack/Server/PeriodicM.hs +52/−48
• Game/LambdaHack/Server/ProtocolM.hs +95/−65
• Game/LambdaHack/Server/ServerOptions.hs +126/−0
• Game/LambdaHack/Server/StartM.hs +70/−87
• Game/LambdaHack/Server/State.hs +52/−171
• GameDefinition/Client/UI/Content/KeyKind.hs +216/−218
• GameDefinition/Content/CaveKind.hs +75/−55
• GameDefinition/Content/ItemKind.hs +138/−127
• GameDefinition/Content/ItemKindActor.hs +5/−4
• GameDefinition/Content/ItemKindBlast.hs +17/−17
• GameDefinition/Content/ItemKindEmbed.hs +9/−9
• GameDefinition/Content/ItemKindOrgan.hs +52/−52
• GameDefinition/Content/ItemKindTemporary.hs +4/−4
• GameDefinition/Content/ModeKind.hs +24/−24
• GameDefinition/Content/PlaceKind.hs +2/−3
• GameDefinition/Content/TileKind.hs +11/−7
• GameDefinition/Main.hs +18/−8
• GameDefinition/PLAYING.md +2/−1
• GameDefinition/TieKnot.hs +22/−40
• LambdaHack.cabal +32/−36
• Makefile +24/−21
• README.md +22/−12
• test/test.hs +7/−2

@@ -1,3 +1,22 @@+## [v0.7.0.0, aka 'The dice are cast'](https://github.com/LambdaHack/LambdaHack/compare/v0.6.2.0...v0.7.0.0)++- decouple tile searching from tile alteration+- refrain from identifying items that are not randomized+- switch away from incapacitated leader to let others revive him+- make rescue easier by not going into negative HP the first time+- fix crowd of friends on another level slowing even actors that melee+- fix missing report about items underneath an actor when changing levels+- API breakage: change the syntax of dice in content+- API addition: introduce cave descriptions+- keep all client states in the server and optimize communication with clients+- improve item choice for identification and item polymorphing+- reset embedded items when altering tile+- replace atomic command filtering with exception catching+- reimplement dice as symbolic expressions inducing multiple RNG calls+- switch to optparse-applicative and rewrite cli handling+- add stack and cabal new-build project files+- improve haddocks across the codebase+ ## [v0.6.2.0, aka 'Zoom out'](https://github.com/LambdaHack/LambdaHack/compare/v0.6.1.0...v0.6.2.0)  - make fireworks slower and so easier to spot

@@ -4,6 +4,7 @@ Andres Loeh Mikolaj Konarski Tuukka Turto+Veronika Romashkina   Fonts 16x16x.fon, 8x8x.fon and 8x8xb.fon are are taken from

@@ -1,26 +1,22 @@--- | Atomic game state transformations.+-- | Atomic game state transformations, their representation and semantics. -- -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Atomic-  ( -- * Re-exported from "Game.LambdaHack.Atomic.MonadAtomic"-    MonadAtomic(..)-    -- * Re-exported from "Game.LambdaHack.Atomic.CmdAtomic"-  , CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), SfxMsg(..)+  ( -- * Re-exported from "Game.LambdaHack.Atomic.CmdAtomic"+    CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), SfxMsg(..)+    -- * Re-exported from "Game.LambdaHack.Atomic.HandleAtomicWrite"+  , handleUpdAtomic     -- * Re-exported from "Game.LambdaHack.Atomic.PosAtomicRead"   , PosAtomic(..), posUpdAtomic, posSfxAtomic, breakUpdAtomic-  , seenAtomicCli, seenAtomicSer, generalMoveItem-  , posProjBody+  , seenAtomicCli, seenAtomicSer     -- * Re-exported from "Game.LambdaHack.Atomic.MonadStateWrite"-  , MonadStateWrite(..)-    -- * Re-exported from "Game.LambdaHack.Atomic.HandleAtomicWrite"-  , handleUpdAtomic+  , MonadStateWrite(..), AtomicFail(..), putState   ) where  import Prelude ()  import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Atomic.HandleAtomicWrite-import Game.LambdaHack.Atomic.MonadAtomic import Game.LambdaHack.Atomic.MonadStateWrite import Game.LambdaHack.Atomic.PosAtomicRead

@@ -8,7 +8,7 @@ -- For example item removal from inventory is not an atomic command, -- but item dropped from the inventory to the ground is. This makes -- it easier to undo the commands. In principle, the commands are the only--- way to affect the basic game state (@State@).+-- way to affect the basic game state ('State'). -- -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.@@ -25,23 +25,27 @@ import Data.Int (Int64) import GHC.Generics (Generic) -import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ClientOptions+-- Dependence on ClientOptions is an anomaly. Instead, probably the raw+-- remaining commandline should be passed and parsed by the client to extract+-- client and ui options from and singnal an error if anything was left.++import           Game.LambdaHack.Client.ClientOptions+import           Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind (ItemKind)+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.TileKind (TileKind)+import           Game.LambdaHack.Content.TileKind (TileKind)  -- | Abstract syntax of atomic commands, that is, atomic game state -- transformations.@@ -53,9 +57,9 @@ instance Binary CmdAtomic  -- | Abstract syntax of atomic updates, that is, atomic commands--- that really change the state. Most of them are an encoding of a game+-- that really change the 'State'. Most of them are an encoding of a game -- state diff, though they also carry some intentional hints--- that help clients determine whether and how to communicate them to players.+-- that help clients determine whether and how to communicate it to players. data UpdAtomic =   -- Create/destroy actors and items.     UpdCreateActor ActorId Actor [(ItemId, Item)]@@ -66,6 +70,8 @@   | UpdLoseActor ActorId Actor [(ItemId, Item)]   | UpdSpotItem Bool ItemId Item ItemQuant Container   | UpdLoseItem Bool ItemId Item ItemQuant Container+  | UpdSpotItemBag Container ItemBag [(ItemId, Item)]+  | UpdLoseItemBag Container ItemBag [(ItemId, Item)]   -- Move actors and items.   | UpdMoveActor ActorId Point Point   | UpdWaitActor ActorId Bool@@ -98,24 +104,25 @@   | UpdUnAgeGame [LevelId]   | UpdDiscover Container ItemId (Kind.Id ItemKind) ItemSeed   | UpdCover Container ItemId (Kind.Id ItemKind) ItemSeed-  | UpdDiscoverKind Container ItemId (Kind.Id ItemKind)-  | UpdCoverKind Container ItemId (Kind.Id ItemKind)+  | UpdDiscoverKind Container ItemKindIx (Kind.Id ItemKind)+  | UpdCoverKind Container ItemKindIx (Kind.Id ItemKind)   | UpdDiscoverSeed Container ItemId ItemSeed   | UpdCoverSeed Container ItemId ItemSeed+  | UpdDiscoverServer ItemId AspectRecord+  | UpdCoverServer ItemId AspectRecord   | UpdPerception LevelId Perception Perception-  | UpdRestart FactionId DiscoveryKind PerLid State Challenge DebugModeCli+  | UpdRestart FactionId PerLid State Challenge ClientOptions   | UpdRestartServer State   | UpdResume FactionId PerLid   | UpdResumeServer State   | UpdKillExit FactionId   | UpdWriteSave-  | UpdMsgAll Text   deriving (Show, Eq, Generic)  instance Binary UpdAtomic  -- | Abstract syntax of atomic special effects, that is, atomic commands--- that only display special effects and don't change the state.+-- that only display special effects and don't change 'State'. data SfxAtomic =     SfxStrike ActorId ActorId ItemId CStore   | SfxRecoil ActorId ActorId ItemId CStore@@ -129,10 +136,13 @@   | SfxShun ActorId Point   | SfxEffect FactionId ActorId IK.Effect Int64   | SfxMsgFid FactionId SfxMsg+  | SfxSortSlots   deriving (Show, Eq, Generic)  instance Binary SfxAtomic +-- | Symbolic representation of text messages sent by server to clients+-- and shown to players. data SfxMsg =     SfxUnexpected ReqFailure   | SfxLoudUpd Bool UpdAtomic@@ -147,7 +157,7 @@   | SfxBracedImmune ActorId   | SfxEscapeImpossible   | SfxTransImpossible-  | SfxIdentifyNothing CStore+  | SfxIdentifyNothing   | SfxPurposeNothing CStore   | SfxPurposeTooFew Int Int   | SfxPurposeUnique@@ -167,6 +177,8 @@   UpdLoseActor aid body ais -> Just $ UpdSpotActor aid body ais   UpdSpotItem verbose iid item k c -> Just $ UpdLoseItem verbose iid item k c   UpdLoseItem verbose iid item k c -> Just $ UpdSpotItem verbose iid item k c+  UpdSpotItemBag c bag ais -> Just $ UpdLoseItemBag c bag ais+  UpdLoseItemBag c bag ais -> Just $ UpdSpotItemBag c bag ais   UpdMoveActor aid fromP toP -> Just $ UpdMoveActor aid toP fromP   UpdWaitActor aid toWait -> Just $ UpdWaitActor aid (not toWait)   UpdDisplaceActor source target -> Just $ UpdDisplaceActor target source@@ -196,10 +208,12 @@   UpdUnAgeGame lids -> Just $ UpdAgeGame lids   UpdDiscover c iid ik seed -> Just $ UpdCover c iid ik seed   UpdCover c iid ik seed -> Just $ UpdDiscover c iid ik seed-  UpdDiscoverKind c iid ik -> Just $ UpdCoverKind c iid ik-  UpdCoverKind c iid ik -> Just $ UpdDiscoverKind c iid ik+  UpdDiscoverKind c ix ik -> Just $ UpdCoverKind c ix ik+  UpdCoverKind c ix ik -> Just $ UpdDiscoverKind c ix ik   UpdDiscoverSeed c iid seed -> Just $ UpdCoverSeed c iid seed   UpdCoverSeed c iid seed -> Just $ UpdDiscoverSeed c iid seed+  UpdDiscoverServer iid aspectRecord -> Just $ UpdCoverServer iid aspectRecord+  UpdCoverServer iid aspectRecord -> Just $ UpdDiscoverServer iid aspectRecord   UpdPerception lid outPer inPer -> Just $ UpdPerception lid inPer outPer   UpdRestart{} -> Just cmd  -- here history ends; change direction   UpdRestartServer{} -> Just cmd  -- here history ends; change direction@@ -207,7 +221,6 @@   UpdResumeServer{} -> Nothing   UpdKillExit{} -> Nothing   UpdWriteSave -> Nothing-  UpdMsgAll{} -> Nothing  -- only generated by @cmdAtomicFilterCli@ or as a hack  undoSfxAtomic :: SfxAtomic -> SfxAtomic undoSfxAtomic cmd = case cmd of@@ -223,6 +236,7 @@   SfxShun aid p -> SfxTrigger aid p   SfxEffect{} -> cmd  -- not ideal?   SfxMsgFid{} -> cmd+  SfxSortSlots -> cmd  undoCmdAtomic :: CmdAtomic -> Maybe CmdAtomic undoCmdAtomic (UpdAtomic cmd) = UpdAtomic <$> undoUpdAtomic cmd

@@ -1,4 +1,5 @@ -- | Semantics of atomic commands shared by client and server.+-- -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Atomic.HandleAtomicWrite@@ -6,13 +7,18 @@ #ifdef EXPOSE_INTERNAL     -- * Internal operations   , updCreateActor, updDestroyActor, updCreateItem, updDestroyItem+  , updSpotItemBag, updLoseItemBag   , updMoveActor, updWaitActor, updDisplaceActor, updMoveItem   , updRefillHP, updRefillCalm   , updTrajectory, updQuitFaction, updLeadFaction   , updDiplFaction, updTacticFaction, updAutoFaction, updRecordKill-  , updAlterTile, updAlterExplorable, updSpotTile, updLoseTile+  , updAlterTile, updAlterExplorable, updSearchTile, updSpotTile, updLoseTile   , updAlterSmell, updSpotSmell, updLoseSmell, updTimeItem-  , updAgeGame, updUnAgeGame, updRestart, updRestartServer, updResumeServer+  , updAgeGame, updUnAgeGame, ageLevel, updDiscover, updCover+  , updDiscoverKind, discoverKind, updCoverKind+  , updDiscoverSeed, discoverSeed, updCoverSeed+  , updDiscoverServer, updCoverServer+  , updRestart, updRestartServer, updResumeServer #endif   ) where @@ -21,31 +27,44 @@ import Game.LambdaHack.Common.Prelude  import qualified Data.EnumMap.Strict as EM-import Data.Int (Int64)+import           Data.Int (Int64) -import Game.LambdaHack.Atomic.CmdAtomic-import Game.LambdaHack.Atomic.MonadStateWrite-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item+import           Game.LambdaHack.Atomic.CmdAtomic+import           Game.LambdaHack.Atomic.MonadStateWrite+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind (ItemKind)-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind (TileKind, unknownId)+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.ItemKind (ItemKind)+import           Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Content.TileKind (TileKind, unknownId)  -- | The game-state semantics of atomic game commands.--- Special effects (@SfxAtomic@) don't modify state.+-- There is no corresponding definition for special effects (`SfxAtomic`),+-- because they don't modify 'State'.+--+-- For each of the commands, we are guaranteed that the client,+-- the command is addressed to, perceives all the positions the command+-- affects (as computed by 'Game.LambdaHack.Atomic.PosAtomicRead.posUpdAtomic').+-- In the code for each semantic function we additonally verify+-- the client is aware of any relevant items and/or actors and we throw+-- the @AtomicFail@ exception if it's not.+-- The server keeps copies of all clients' states and, before sending a command+-- to a client, applies it to the client's state copy.+-- If @AtomicFail@ is signalled, the command is ignored for that client.+-- This enables simpler server code that addresses commands to all clients+-- that can see it, even though not all are able to process it. handleUpdAtomic :: MonadStateWrite m => UpdAtomic -> m () handleUpdAtomic cmd = case cmd of   UpdCreateActor aid body ais -> updCreateActor aid body ais@@ -56,6 +75,8 @@   UpdLoseActor aid body ais -> updDestroyActor aid body ais   UpdSpotItem _ iid item kit c -> updCreateItem iid item kit c   UpdLoseItem _ iid item kit c -> updDestroyItem iid item kit c+  UpdSpotItemBag c bag ais -> updSpotItemBag c bag ais+  UpdLoseItemBag c bag ais -> updLoseItemBag c bag ais   UpdMoveActor aid fromP toP -> updMoveActor aid fromP toP   UpdWaitActor aid toWait -> updWaitActor aid toWait   UpdDisplaceActor source target -> updDisplaceActor source target@@ -72,8 +93,8 @@   UpdRecordKill aid ikind k -> updRecordKill aid ikind k   UpdAlterTile lid p fromTile toTile -> updAlterTile lid p fromTile toTile   UpdAlterExplorable lid delta -> updAlterExplorable lid delta-  UpdSearchTile{} -> return ()  -- only for clients-  UpdHideTile{} -> return ()  -- only for clients+  UpdSearchTile aid p toTile -> updSearchTile aid p toTile+  UpdHideTile{} -> undefined   UpdSpotTile lid ts -> updSpotTile lid ts   UpdLoseTile lid ts -> updLoseTile lid ts   UpdAlterSmell lid p fromSm toSm -> updAlterSmell lid p fromSm toSm@@ -82,69 +103,59 @@   UpdTimeItem iid c fromIt toIt -> updTimeItem iid c fromIt toIt   UpdAgeGame lids -> updAgeGame lids   UpdUnAgeGame lids -> updUnAgeGame lids-  UpdDiscover{} -> return ()      -- We can't keep dicovered data in State,-  UpdCover{} -> return ()         -- because server saves all atomic commands-  UpdDiscoverKind{} -> return ()  -- to apply their inverses for undo,-  UpdCoverKind{} -> return ()     -- so they would wipe out server knowledge.-  UpdDiscoverSeed{} -> return ()-  UpdCoverSeed{} -> return ()+  UpdDiscover c iid ik seed -> updDiscover c iid ik seed+  UpdCover c iid ik seed -> updCover c iid ik seed+  UpdDiscoverKind c ix ik -> updDiscoverKind c ix ik+  UpdCoverKind c ix ik -> updCoverKind c ix ik+  UpdDiscoverSeed c iid seed -> updDiscoverSeed c iid seed+  UpdCoverSeed c iid seed -> updCoverSeed c iid seed+  UpdDiscoverServer iid aspectRecord -> updDiscoverServer iid aspectRecord+  UpdCoverServer iid aspectRecord -> updCoverServer iid aspectRecord   UpdPerception _ outPer inPer ->     assert (not (nullPer outPer && nullPer inPer)) (return ())-  UpdRestart _ _ _ s _ _ -> updRestart s+  UpdRestart _ _ s _ _ -> updRestart s   UpdRestartServer s -> updRestartServer s   UpdResume{} -> return ()   UpdResumeServer s -> updResumeServer s   UpdKillExit{} -> return ()   UpdWriteSave -> return ()-  UpdMsgAll{} -> return () --- | Creates an actor. Note: after this command, usually a new leader+-- Note: after this command, usually a new leader -- for the party should be elected (in case this actor is the only one alive). updCreateActor :: MonadStateWrite m                => ActorId -> Actor -> [(ItemId, Item)] -> m () updCreateActor aid body ais = do   -- Add actor to @sactorD@.+  -- The exception is possible, e.g., when we teleport and so see our actor+  -- at the new location, but also the location is part of new perception,+  -- so @UpdSpotActor@ is sent.   let f Nothing = Just body-      f (Just b) = error $ "actor already added"-                           `showFailure` (aid, body, b)+      f (Just b) = assert (body == b `blame` (aid, body, b)) $+        atomicFail $ "actor already added" `showFailure` (aid, body, b)   modifyState $ updateActorD $ EM.alter f aid   -- Add actor to @sprio@.   let g Nothing = Just [aid]       g (Just l) = #ifdef WITH_EXPENSIVE_ASSERTIONS+        -- Not so much expensive, as doubly impossible.         assert (aid `notElem` l `blame` "actor already added"                                 `swith` (aid, body, l)) #endif         (Just $ aid : l)   updateLevel (blid body) $ updateActorMap (EM.alter g (bpos body))-  -- Actor's items may or may not be already present in @sitemD@,-  -- regardless if they are already present otherwise in the dungeon.-  -- We re-add them all to save time determining which really need it.-  forM_ ais $ \(iid, item) -> do-    let h item1 item2 =-          assert (itemsMatch item1 item2-                  `blame` "inconsistent created actor items"-                  `swith` (aid, body, iid, item1, item2))-                 item2 -- keep the first found level-    modifyState $ updateItemD $ EM.insertWith h iid item--itemsMatch :: Item -> Item -> Bool-itemsMatch item1 item2 =-  jkindIx item1 == jkindIx item2-  -- && aspects and effects are the same, but too much writing;-  -- Note that nothing else needs to be the same, since items are merged-  -- and clients have different views on dungeon items than the server.+  addAis ais+  aspectRecord <- getsState $ aspectRecordFromActor body+  modifyState $ updateActorAspect $ EM.insert aid aspectRecord --- | Kills an actor.+-- If a leader dies, a new leader should be elected on the server+-- before this command is executed (not checked). updDestroyActor :: MonadStateWrite m                 => ActorId -> Actor -> [(ItemId, Item)] -> m () updDestroyActor aid body ais = do-  -- If a leader dies, a new leader should be elected on the server-  -- before this command is executed (not checked).-  itemD <- getsState sitemD-  let match (iid, item) = itemsMatch (itemD EM.! iid) item   -- Assert that actor's items belong to @sitemD@. Do not remove those   -- that do not appear anywhere else, for simplicity and speed.+  itemD <- getsState sitemD+  let match (iid, item) = itemsMatch (itemD EM.! iid) item   let !_A = assert (allB match ais `blame` "destroyed actor items not found"                     `swith` (aid, body, ais, itemD)) ()   -- Remove actor from @sactorD@.@@ -156,31 +167,32 @@   let g Nothing = error $ "actor already removed" `showFailure` (aid, body)       g (Just l) = #ifdef WITH_EXPENSIVE_ASSERTIONS+        -- Not so much expensive, as doubly impossible.         assert (aid `elem` l `blame` "actor already removed"                              `swith` (aid, body, l)) #endif         (let l2 = delete aid l          in if null l2 then Nothing else Just l2)   updateLevel (blid body) $ updateActorMap (EM.alter g (bpos body))+  modifyState $ updateActorAspect $ EM.delete aid --- | Create a few copies of an item that is already registered for the dungeon+-- Create a few copies of an item that is already registered for the dungeon -- (in @sitemRev@ field of @StateServer@). updCreateItem :: MonadStateWrite m               => ItemId -> Item -> ItemQuant -> Container -> m () updCreateItem iid item kit@(k, _) c = assert (k > 0) $ do-  -- The item may or may not be already present in @sitemD@,-  -- regardless if it's actually present in the dungeon.-  -- If items equivalent, pick the one found on easier level.-  let f item1 item2 =-        assert (itemsMatch item1 item2)-               item2 -- keep the first found level-  modifyState $ updateItemD $ EM.insertWith f iid item+  addAis [(iid, item)]   insertItemContainer iid kit c+  case c of+    CActor aid store ->+      when (store `elem` [CEqp, COrgan]) $ addItemToActor iid item k aid+    _ -> return () --- | Destroy some copies (possibly not all) of an item.+-- Destroy some copies (possibly not all) of an item. updDestroyItem :: MonadStateWrite m                => ItemId -> Item -> ItemQuant -> Container -> m () updDestroyItem iid item kit@(k, _) c = assert (k > 0) $ do+  deleteItemContainer iid kit c   -- Do not remove the item from @sitemD@ nor from @sitemRev@,   -- It's incredibly costly and not noticeable for the player.   -- However, assert the item is registered in @sitemD@.@@ -190,8 +202,43 @@                         Just item0 -> itemsMatch item0 item)                     `blame` "item already removed"                     `swith` (iid, item, itemD)) ()-  deleteItemContainer iid kit c+  case c of+    CActor aid store ->+      when (store `elem` [CEqp, COrgan]) $ addItemToActor iid item (-k) aid+    _ -> return () +updSpotItemBag :: MonadStateWrite m+               => Container -> ItemBag -> [(ItemId, Item)] -> m ()+updSpotItemBag c bag ais = assert (EM.size bag > 0+                                   && EM.size bag == length ais) $ do+  addAis ais+  insertBagContainer bag c+  case c of+    CActor aid store ->+      when (store `elem` [CEqp, COrgan]) $+        forM_ ais $ \(iid, item) ->+                      addItemToActor iid item (fst $ bag EM.! iid) aid+    _ -> return ()++updLoseItemBag :: MonadStateWrite m+               => Container -> ItemBag -> [(ItemId, Item)] -> m ()+updLoseItemBag c bag ais = assert (EM.size bag > 0+                                   && EM.size bag == length ais) $ do+  deleteBagContainer bag c+  -- Do not remove the items from @sitemD@ nor from @sitemRev@,+  -- It's incredibly costly and not noticeable for the player.+  -- However, assert the items are registered in @sitemD@.+  itemD <- getsState sitemD+  let match (iid, item) = itemsMatch (itemD EM.! iid) item+  let !_A = assert (allB match ais `blame` "items already removed"+                                   `swith` (c, bag, ais, itemD)) ()+  case c of+    CActor aid store ->+      when (store `elem` [CEqp, COrgan]) $+        forM_ ais $ \(iid, item) ->+                      addItemToActor iid item (- (fst $ bag EM.! iid)) aid+    _ -> return ()+ updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m () updMoveActor aid fromP toP = assert (fromP /= toP) $ do   body <- getsState $ getActorBody aid@@ -226,30 +273,49 @@ updMoveItem :: MonadStateWrite m             => ItemId -> Int -> ActorId -> CStore -> CStore             -> m ()-updMoveItem iid k aid c1 c2 = assert (k > 0 && c1 /= c2) $ do+updMoveItem iid k aid s1 s2 = assert (k > 0 && s1 /= s2) $ do   b <- getsState $ getActorBody aid-  bag <- getsState $ getBodyStoreBag b c1+  bag <- getsState $ getBodyStoreBag b s1   case iid `EM.lookup` bag of-    Nothing -> error $ "" `showFailure` (iid, k, aid, c1, c2)+    Nothing -> error $ "" `showFailure` (iid, k, aid, s1, s2)     Just (_, it) -> do-      deleteItemActor iid (k, take k it) aid c1-      insertItemActor iid (k, take k it) aid c2+      deleteItemActor iid (k, take k it) aid s1+      insertItemActor iid (k, take k it) aid s2+  case s1 of+    CEqp -> case s2 of+      COrgan -> return ()+      _ -> do+        itemBase <- getsState $ getItemBody iid+        addItemToActor iid itemBase (-k) aid+    COrgan -> case s2 of+      CEqp -> return ()+      _ -> do+        itemBase <- getsState $ getItemBody iid+        addItemToActor iid itemBase (-k) aid+    _ ->+      when (s2 `elem` [CEqp, COrgan]) $ do+        itemBase <- getsState $ getItemBody iid+        addItemToActor iid itemBase k aid  updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m ()-updRefillHP aid n =+updRefillHP aid nRaw =   updateActor aid $ \b ->-    b { bhp = bhp b + n-      , bhpDelta = let oldD = bhpDelta b-                   in case compare n 0 of-                     EQ -> ResDelta { resCurrentTurn = (0, 0)-                                    , resPreviousTurn = resCurrentTurn oldD }-                     LT -> oldD {resCurrentTurn =-                                   ( fst (resCurrentTurn oldD) + n-                                   , snd (resCurrentTurn oldD) )}-                     GT -> oldD {resCurrentTurn =-                                   ( fst (resCurrentTurn oldD)-                                   , snd (resCurrentTurn oldD) + n )}-      }+    -- Make rescue easier by not going into negative HP the first time.+    let newRawHP = bhp b + nRaw+        newHP = if bhp b <= 0 then newRawHP else max 0 newRawHP+        n = newHP - bhp b+    in b { bhp = newHP+         , bhpDelta = let oldD = bhpDelta b+                      in case compare n 0 of+                        EQ -> ResDelta { resCurrentTurn = (0, 0)+                                       , resPreviousTurn = resCurrentTurn oldD }+                        LT -> oldD {resCurrentTurn =+                                      ( fst (resCurrentTurn oldD) + n+                                      , snd (resCurrentTurn oldD) )}+                        GT -> oldD {resCurrentTurn =+                                      ( fst (resCurrentTurn oldD)+                                      , snd (resCurrentTurn oldD) + n )}+         }  updRefillCalm :: MonadStateWrite m => ActorId -> Int64 -> m () updRefillCalm aid n =@@ -303,7 +369,7 @@   mtb <- getsState $ \s -> flip getActorBody s <$> target   let !_A = assert (maybe True (not . bproj) mtb                     `blame` (fid, source, target, mtb, fact)) ()-  let !_A = assert (source == _gleader fact+  let !_A = assert (source == gleader fact                     `blame` "unexpected actor leader"                     `swith` (fid, source, target, mtb, fact)) ()   let adj fa = fa {_gleader = target}@@ -323,12 +389,6 @@     updateFaction fid1 (adj fid2)     updateFaction fid2 (adj fid1) -updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m ()-updAutoFaction fid st =-  updateFaction fid (\fact ->-    assert (isAIFact fact == not st)-    $ fact {gplayer = automatePlayer st (gplayer fact)})- updTacticFaction :: MonadStateWrite m => FactionId -> Tactic -> Tactic -> m () updTacticFaction fid toT fromT = do   let adj fact =@@ -337,7 +397,13 @@            $ fact {gplayer = player {ftactic = toT}}   updateFaction fid adj --- | Record a given number (usually just 1, or -1 for undo) of actor kills+updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m ()+updAutoFaction fid st =+  updateFaction fid (\fact ->+    assert (isAIFact fact == not st)+    $ fact {gplayer = automatePlayer st (gplayer fact)})++-- Record a given number (usually just 1, or -1 for undo) of actor kills -- for score calculation. updRecordKill :: MonadStateWrite m => ActorId -> Kind.Id ItemKind -> Int -> m () updRecordKill aid ikind k = do@@ -354,76 +420,74 @@     -- as it could be and there is a higher chance of getting back alive     -- the actor, the human player has grown attached to. --- | Alter an attribute (actually, the only, the defining attribute)+-- Alter an attribute (actually, the only, the defining attribute) -- of a visible tile. This is similar to e.g., @UpdTrajectory@. ----- For now, we don't remove embedded items when altering a tile--- and neither do we create fresh ones. It works fine, e.g., for tiles on fire--- that change into burnt out tile and then the fire item can no longer--- be triggered due to @alterMinSkillKind@ excluding items without @Embed@,--- even if the burnt tile has low enough @talter@.+-- Removing and creating embedded items when altering a tile+-- is done separately via @UpdCreateItem@ and @UpdDestroyItem@. updAlterTile :: MonadStateWrite m              => LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind              -> m () updAlterTile lid p fromTile toTile = assert (fromTile /= toTile) $ do-  Kind.COps{cotile, coTileSpeedup} <- getsState scops+  Kind.COps{coTileSpeedup} <- getsState scops   lvl <- getLevel lid-  -- The second alternative below can happen if, e.g., a client remembers,-  -- but does not see the tile (so does not notice the SearchTile action),-  -- and it suddenly changes into another tile,-  -- which at the same time becomes visible (e.g., an open door).-  let adj ts = assert (ts PointArray.! p == fromTile-                       || ts PointArray.! p == Tile.hideAs cotile fromTile-                       `blame` "unexpected altered tile kind"-                       `swith` (lid, p, fromTile, toTile, ts PointArray.! p))-               $ ts PointArray.// [(p, toTile)]-  updateLevel lid $ updateTile adj-  case ( Tile.isExplorable coTileSpeedup fromTile-       , Tile.isExplorable coTileSpeedup toTile ) of-    (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl + 1}-    (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl - 1}-    _ -> return ()+  let t = lvl `at` p+  if t /= fromTile+  then atomicFail "tile to alter is different than assumed"+  else do+    let adj ts = ts PointArray.// [(p, toTile)]+    updateLevel lid $ updateTile adj+    case ( Tile.isExplorable coTileSpeedup fromTile+         , Tile.isExplorable coTileSpeedup toTile ) of+      (False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl + 1}+      (True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl - 1}+      _ -> return ()  updAlterExplorable :: MonadStateWrite m => LevelId -> Int -> m () updAlterExplorable lid delta = assert (delta /= 0) $   updateLevel lid $ \lvl -> lvl {lexplorable = lexplorable lvl + delta} --- Notice previously invisible tiles. This is similar to @UpdSpotActor@,--- but done in bulk, because it often involves dozens of tiles pers move.--- We don't check that the tiles at the positions in question are unknown--- to save computation, especially for clients that remember tiles--- at previously seen positions. Similarly, when updating the @lseen@--- field we don't assume the tiles were unknown previously.+-- Showing to the client the embedded items, if any, is done elsewhere.+updSearchTile :: MonadStateWrite m+              => ActorId -> Point -> Kind.Id TileKind -> m ()+updSearchTile aid p toTile = do+  Kind.COps{cotile} <- getsState scops+  b <- getsState $ getActorBody aid+  lvl <- getLevel $ blid b+  let t = lvl `at` p+  if t == toTile+  then atomicFail "tile already searched"+  else assert (Just t == Tile.hideAs cotile toTile) $ do+    updLoseTile (blid b) [(p, t)]+    updSpotTile (blid b) [(p, toTile)]  -- not the hidden version this one time++-- Notice previously invisible tiles. This is done in bulk,+-- because it often involves dozens of tiles per move.+-- We verify that the old tiles at the positions in question+-- are indeed unknown. updSpotTile :: MonadStateWrite m             => LevelId -> [(Point, Kind.Id TileKind)] -> m () updSpotTile lid ts = assert (not $ null ts) $ do   Kind.COps{coTileSpeedup} <- getsState scops-  Level{ltile} <- getLevel lid-  let adj tileMap = tileMap PointArray.// ts+  let unk tileMap (p, _) = tileMap PointArray.! p == unknownId+      adj tileMap = assert (all (unk tileMap) ts) $ tileMap PointArray.// ts   updateLevel lid $ updateTile adj-  let f (p, t2) = do-        let t1 = ltile PointArray.! p-        case (Tile.isExplorable coTileSpeedup t1, Tile.isExplorable coTileSpeedup t2) of-          (False, True) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl+1}-          (True, False) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl-1}-          _ -> return ()+  let f (_, t1) = when (Tile.isExplorable coTileSpeedup t1) $+        updateLevel lid $ \lvl -> lvl {lseen = lseen lvl + 1}   mapM_ f ts --- Stop noticing previously visible tiles. Unlike @updSpotActor@, it verifies--- the state of the tiles before changing them.+-- Stop noticing previously visible tiles. It verifies+-- the state of the tiles before wiping them out. updLoseTile :: MonadStateWrite m             => LevelId -> [(Point, Kind.Id TileKind)] -> m () updLoseTile lid ts = assert (not $ null ts) $ do   Kind.COps{coTileSpeedup} <- getsState scops-  let matches _ [] = True-      matches tileMap ((p, ov) : rest) =-        tileMap PointArray.! p == ov && matches tileMap rest+  let matches tileMap (p, ov) = tileMap PointArray.! p == ov       tu = map (second (const unknownId)) ts-      adj tileMap = assert (matches tileMap ts) $ tileMap PointArray.// tu+      adj tileMap = assert (all (matches tileMap) ts) $ tileMap PointArray.// tu   updateLevel lid $ updateTile adj-  let f (_, t1) =-        when (Tile.isExplorable coTileSpeedup t1) $-          updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1}+  let f (_, t1) = when (Tile.isExplorable coTileSpeedup t1) $+        updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1}   mapM_ f ts  updAlterSmell :: MonadStateWrite m => LevelId -> Point -> Time -> Time -> m ()@@ -466,7 +530,6 @@       insertItemContainer iid (k, toIt) c     Nothing -> error $ "" `showFailure` (bag, iid, c, fromIt, toIt) --- | Age the game. updAgeGame :: MonadStateWrite m => [LevelId] -> m () updAgeGame lids = do   modifyState $ updateTime $ flip timeShift (Delta timeClip)@@ -480,6 +543,104 @@ ageLevel :: MonadStateWrite m => Delta Time -> LevelId -> m () ageLevel delta lid =   updateLevel lid $ \lvl -> lvl {ltime = timeShift (ltime lvl) delta}++updDiscover :: MonadStateWrite m+            => Container -> ItemId -> Kind.Id ItemKind -> ItemSeed -> m ()+updDiscover _c iid ik seed = do+  itemD <- getsState sitemD+  case EM.lookup iid itemD of+    Nothing -> atomicFail "discovered item unknown"+    Just item -> do+      discoKind <- getsState sdiscoKind+      case EM.lookup (jkindIx item) discoKind of+        Just KindMean{kmConst} -> do+          discoAspect <- getsState sdiscoAspect+          if kmConst || iid `EM.member` discoAspect+          then atomicFail "item already fully discovered"+          else discoverSeed iid seed+        Nothing -> do+          KindMean{kmConst} <- discoverKind (jkindIx item) ik+          unless kmConst $ discoverSeed iid seed+  resetActorAspect++updCover :: Container -> ItemId -> Kind.Id ItemKind -> ItemSeed -> m ()+updCover _c _iid _ik _seed = undefined++updDiscoverKind :: MonadStateWrite m+                => Container -> ItemKindIx -> Kind.Id ItemKind -> m ()+updDiscoverKind _c ix kmKind = do+  discoKind <- getsState sdiscoKind+  if ix `EM.member` discoKind+  then atomicFail "item kind already discovered"+  else do+    void $ discoverKind ix kmKind+    resetActorAspect++discoverKind :: MonadStateWrite m+             => ItemKindIx -> Kind.Id ItemKind -> m KindMean+discoverKind ix kmKind = do+  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops+  let kind = okind kmKind+      kmMean = meanAspect kind+      kmConst = not $ aspectsRandom kind+      km = KindMean{..}+      f Nothing = Just km+      f Just{} = error $ "already discovered" `showFailure` (ix, kmKind)+  modifyState $ updateDiscoKind $ \discoKind1 ->+    EM.alter f ix discoKind1+  return km++updCoverKind :: Container -> ItemKindIx -> Kind.Id ItemKind -> m ()+updCoverKind _c _ix _ik = undefined++updDiscoverSeed :: MonadStateWrite m+                => Container -> ItemId -> ItemSeed -> m ()+updDiscoverSeed _c iid seed = do+  itemD <- getsState sitemD+  case EM.lookup iid itemD of+    Nothing -> atomicFail "discovered item unknown"+    Just item -> do+      discoKind <- getsState sdiscoKind+      case EM.lookup (jkindIx item) discoKind of+        Nothing -> error "discovered item kind unknown"+        Just KindMean{kmConst} -> do+          discoAspect <- getsState sdiscoAspect+          if kmConst || iid `EM.member` discoAspect+          then atomicFail "item seed already discovered"+          else do+            discoverSeed iid seed+            resetActorAspect++discoverSeed :: MonadStateWrite m => ItemId -> ItemSeed -> m ()+discoverSeed iid seed = do+  Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops+  item <- getsState $ getItemBody iid+  totalDepth <- getsState stotalDepth+  Level{ldepth} <- getLevel $ jlid item+  discoKind <- getsState sdiscoKind+  let KindMean{..} = fromMaybe (error "discovered item kind unknown")+                               (EM.lookup (jkindIx item) discoKind)+      kind = okind kmKind+      aspects = seedToAspect seed kind ldepth totalDepth+      f Nothing = Just aspects+      f Just{} = error $ "already discovered" `showFailure` (iid, seed)+  assert (not kmConst) $+    modifyState $ updateDiscoAspect $ \discoAspect1 ->+      EM.alter f iid discoAspect1++updCoverSeed :: Container -> ItemId -> ItemSeed -> m ()+updCoverSeed _c _iid _seed = undefined++updDiscoverServer :: MonadStateWrite m => ItemId -> AspectRecord -> m ()+updDiscoverServer iid aspectRecord =+  modifyState $ updateDiscoAspect $ \discoAspect1 ->+    EM.insert iid aspectRecord discoAspect1++updCoverServer :: MonadStateWrite m => ItemId -> AspectRecord -> m ()+updCoverServer iid aspectRecord =+  modifyState $ updateDiscoAspect $ \discoAspect1 ->+    assert (discoAspect1 EM.! iid == aspectRecord)+    $ EM.delete iid discoAspect1  updRestart :: MonadStateWrite m => State -> m () updRestart = putState

@@ -1,20 +0,0 @@--- | Atomic monads for handling atomic game state transformations.-module Game.LambdaHack.Atomic.MonadAtomic-  ( MonadAtomic(..)-  ) where--import Prelude ()--import Game.LambdaHack.Atomic.CmdAtomic-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception---- | The monad for executing atomic game state transformations.-class MonadStateRead m => MonadAtomic m where-  -- | Execute an atomic command that really changes the state.-  execUpdAtomic :: UpdAtomic -> m ()-  -- | Execute an atomic command that only displays special effects.-  execSfxAtomic :: SfxAtomic -> m ()-  execSendPer :: FactionId -> LevelId-              -> Perception -> Perception -> Perception -> m ()

@@ -1,17 +1,27 @@--- | The monad for writing to the game state and related operations.+-- | The monad for writing to the main game state. module Game.LambdaHack.Atomic.MonadStateWrite-  ( MonadStateWrite(..)-  , putState, updateLevel, updateActor, updateFaction-  , insertItemContainer, insertItemActor, deleteItemContainer, deleteItemActor-  , updateFloor, updateActorMap, moveActorMap-  , updateTile, updateSmell+  ( MonadStateWrite(..), AtomicFail(..), atomicFail+  , putState, updateLevel, updateActor, updateFaction, moveActorMap+  , insertBagContainer, insertItemContainer, insertItemActor+  , deleteBagContainer, deleteItemContainer, deleteItemActor+  , addAis, itemsMatch, addItemToActor, resetActorAspect+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , insertItemFloor, insertItemEmbed+  , insertItemOrgan, insertItemEqp, insertItemInv, insertItemSha+  , deleteItemFloor, deleteItemEmbed+  , deleteItemOrgan, deleteItemEqp, deleteItemInv, deleteItemSha+  , rmFromBag+#endif   ) where  import Prelude ()  import Game.LambdaHack.Common.Prelude +import qualified Control.Exception as Ex import qualified Data.EnumMap.Strict as EM+import           Data.Key (mapWithKeyM_)  import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState@@ -23,23 +33,49 @@ import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State +-- | The monad for writing to the main game state. Atomic updates ('UpdAtomic')+-- are given semantics in this monad. class MonadStateRead m => MonadStateWrite m where   modifyState :: (State -> State) -> m () +-- | Exception signifying that atomic action failed because+-- the information it carries is inconsistent with the client's state,+-- (e.g., because the client knows too little to understand the command+-- or already deduced the state change from earlier commands+-- or is confused, amnesiac or sees illusory actors or tiles).+-- Whenever we know the failure is logically impossible,+-- we don't throw the @AtomicFail@ exception, but insert a normal assertion+-- or @error@ call, which are never caught nor handled.+newtype AtomicFail = AtomicFail String+  deriving Show++instance Ex.Exception AtomicFail++atomicFail :: String -> a+atomicFail = Ex.throw . AtomicFail+ putState :: MonadStateWrite m => State -> m () putState s = modifyState (const s) --- | Update the items on the ground map.-updateFloor :: (ItemFloor -> ItemFloor) -> Level -> Level-updateFloor f lvl = lvl {lfloor = f (lfloor lvl)}+-- INLIning offers no speedup, increases alloc and binary size.+-- EM.alter not necessary, because levels not removed, so little risk+-- of adjusting at absent index.+updateLevel :: MonadStateWrite m => LevelId -> (Level -> Level) -> m ()+updateLevel lid f = modifyState $ updateDungeon $ EM.adjust f lid --- | Update the items embedded in a tile on the level.-updateEmbed :: (ItemFloor -> ItemFloor) -> Level -> Level-updateEmbed f lvl = lvl {lembed = f (lembed lvl)}+-- INLIning doesn't help despite probably canceling the alt indirection.+-- perhaps it's applied automatically due to INLINABLE.+updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m ()+updateActor aid f = do+  let alt Nothing = error $ "no body to update" `showFailure` aid+      alt (Just b) = Just $ f b+  modifyState $ updateActorD $ EM.alter alt aid --- | Update the actors on the ground map.-updateActorMap :: (ActorMap -> ActorMap) -> Level -> Level-updateActorMap f lvl = lvl {lactor = f (lactor lvl)}+updateFaction :: MonadStateWrite m => FactionId -> (Faction -> Faction) -> m ()+updateFaction fid f = do+  let alt Nothing = error $ "no faction to update" `showFailure` fid+      alt (Just fact) = Just $ f fact+  modifyState $ updateFactionD $ EM.alter alt fid  moveActorMap :: MonadStateWrite m => ActorId -> Actor -> Actor -> m () moveActorMap aid body newBody = do@@ -63,34 +99,23 @@                  . EM.alter rmActor (bpos body)   updateLevel (blid body) $ updateActorMap updActor --- | Update the tile map.-updateTile :: (TileMap -> TileMap) -> Level -> Level-updateTile f lvl = lvl {ltile = f (ltile lvl)}---- | Update the smell map.-updateSmell :: (SmellMap -> SmellMap) -> Level -> Level-updateSmell f lvl = lvl {lsmell = f (lsmell lvl)}---- INLIning offers no speedup, increases alloc and binary size.--- EM.alter not necessary, because levels not removed, so little risk--- of adjusting at absent index.--- | Update a given level data within state.-updateLevel :: MonadStateWrite m => LevelId -> (Level -> Level) -> m ()-updateLevel lid f = modifyState $ updateDungeon $ EM.adjust f lid---- INLIning doesn't help despite probably canceling the alt indirection.--- perhaps it's applied automatically due to INLINABLE.-updateActor :: MonadStateWrite m => ActorId -> (Actor -> Actor) -> m ()-updateActor aid f = do-  let alt Nothing = error $ "no body to update" `showFailure` aid-      alt (Just b) = Just $ f b-  modifyState $ updateActorD $ EM.alter alt aid--updateFaction :: MonadStateWrite m => FactionId -> (Faction -> Faction) -> m ()-updateFaction fid f = do-  let alt Nothing = error $ "no faction to update" `showFailure` fid-      alt (Just fact) = Just $ f fact-  modifyState $ updateFactionD $ EM.alter alt fid+insertBagContainer :: MonadStateWrite m+                   => ItemBag -> Container -> m ()+insertBagContainer bag c = case c of+  CFloor lid pos -> do+    let alt Nothing = Just bag+        alt (Just bag2) = atomicFail $ "floor bag not empty"+                                       `showFailure` (bag2, lid, pos, bag)+    updateLevel lid $ updateFloor $ EM.alter alt pos+  CEmbed lid pos -> do+    let alt Nothing = Just bag+        alt (Just bag2) = atomicFail $ "embed bag not empty"+                                       `showFailure` (bag2, lid, pos, bag)+    updateLevel lid $ updateEmbed $ EM.alter alt pos+  CActor aid store ->+    -- Very unlikely case, so we prefer brevity over performance.+    mapWithKeyM_ (\iid kit -> insertItemActor iid kit aid store) bag+  CTrunk{} -> return ()  insertItemContainer :: MonadStateWrite m                     => ItemId -> ItemQuant -> Container -> m ()@@ -162,6 +187,24 @@       upd = EM.unionWith mergeItemQuant bag   updateFaction fid $ \fact -> fact {gsha = upd (gsha fact)} +deleteBagContainer :: MonadStateWrite m+                   => ItemBag -> Container -> m ()+deleteBagContainer bag c = case c of+  CFloor lid pos -> do+    let alt Nothing = atomicFail $ "floor bag already empty"+                                   `showFailure` (lid, pos, bag)+        alt (Just bag2) = assert (bag == bag2) Nothing+    updateLevel lid $ updateFloor $ EM.alter alt pos+  CEmbed lid pos -> do+    let alt Nothing = atomicFail $ "embed bag already empty"+                                   `showFailure` (lid, pos, bag)+        alt (Just bag2) = assert (bag == bag2 `blame` (bag, bag2)) Nothing+    updateLevel lid $ updateEmbed $ EM.alter alt pos+  CActor aid store ->+    -- Very unlikely case, so we prefer brevity over performance.+    mapWithKeyM_ (\iid kit -> deleteItemActor iid kit aid store) bag+  CTrunk{} -> error $ "" `showFailure` c+ deleteItemContainer :: MonadStateWrite m                     => ItemId -> ItemQuant -> Container -> m () deleteItemContainer iid kit c = case c of@@ -239,3 +282,42 @@                         `blame` (rmIt, take k it, n, kit, iid, bag))                 $ Just (n - k, take (n - k) it)   in EM.alter rfb iid bag++-- Actor's items may or may not be already present in @sitemD@,+-- regardless if they are already present otherwise in the dungeon.+-- We re-add them all to save time determining which really need it.+-- If collision occurs, pick the item found on easier level.+addAis :: MonadStateWrite m => [(ItemId, Item)] -> m ()+addAis ais = do+  let h item1 item2 =+        assert (itemsMatch item1 item2+                `blame` "inconsistent added items"+                `swith` (item1, item2, ais))+               item2 -- keep the first found level+  forM_ ais $ \(iid, item) ->+    modifyState+    $ updateItemIxMap (EM.insertWith (++) (jkindIx item) [iid])+      . updateItemD (EM.insertWith h iid item)++itemsMatch :: Item -> Item -> Bool+itemsMatch item1 item2 =+  jkindIx item1 == jkindIx item2+  -- Note that nothing else needs to be the same, since items are merged+  -- and clients have different views on dungeon items than the server.++addItemToActor :: MonadStateWrite m => ItemId -> Item -> Int -> ActorId -> m ()+addItemToActor iid itemBase k aid = do+  arItem <- getsState $ aspectRecordFromItem iid itemBase+  let f arActor = sumAspectRecord [(arActor, 1), (arItem, k)]+  modifyState $ updateActorAspect $ EM.adjust f aid++resetActorAspect :: MonadStateWrite m => m ()+resetActorAspect = do+  -- Each actor's equipment and organs would need to be inspected,+  -- the iid looked up, e.g., if it wasn't in old discoKind, but is in new,+  -- and then aspect record updated, so it's simpler and not much more+  -- expensive to generate new sactorAspect. Optimize only after profiling.+  -- Also note this doesn't get invoked on the server, because it bails out+  -- earlier, upon noticing the item is already fully known.+  actorAspect <- getsState actorAspectInDungeon+  modifyState $ updateActorAspect $ const actorAspect

@@ -1,23 +1,27 @@--- | Semantics of atomic commands shared by client and server.+-- | Representation and computation of visiblity of atomic commands+-- by clients.+-- -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Atomic.PosAtomicRead   ( PosAtomic(..), posUpdAtomic, posSfxAtomic-  , breakUpdAtomic, seenAtomicCli, seenAtomicSer, generalMoveItem, posProjBody+  , breakUpdAtomic, seenAtomicCli, seenAtomicSer+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , posProjBody, singleAid, doubleAid, singleContainer+#endif   ) where  import Prelude ()  import Game.LambdaHack.Common.Prelude -import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES  import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead@@ -35,29 +39,35 @@   | PosFidAndSight [FactionId] LevelId [Point]                                 -- ^ observers and the faction notice   | PosSmell LevelId [Point]    -- ^ whomever smells all the positions, notices-  | PosFid FactionId            -- ^ only the faction notices-  | PosFidAndSer (Maybe LevelId) FactionId  -- ^ faction and server notices+  | PosFid FactionId            -- ^ only the faction notices, server doesn't+  | PosFidAndSer (Maybe LevelId) FactionId+                                -- ^ faction and server notices   | PosSer                      -- ^ only the server notices   | PosAll                      -- ^ everybody notices   | PosNone                     -- ^ never broadcasted, but sent manually   deriving (Show, Eq) --- | Produce the positions where the atomic update takes place.+-- | Produce the positions where the atomic update takes place or, more+-- generally, the conditions under which the update can be noticed by+-- a client. ----- The goal of the mechanics is to ensure the commands don't carry--- significantly more information than their corresponding state diffs would.--- In other words, the atomic commands involving the positions seen by a client--- should convey similar information as the client would get by directly--- observing the changes the commands enact on the visible portion of server--- game state. The client is then free to change its copy of game state--- accordingly or not --- it only partially reflects reality anyway.+-- The goal of this mechanics is to ensure that atomic commands involving+-- some positions visible by a client convey similar information as the client+-- would get by directly observing the changes+-- of the portion of server state limited to the visible positions.+-- Consequently, when the visible commands are later applied+-- to the client's state, the state stays consistent+-- --- in sync with the server state and correctly limited by visiblity.+-- There is some wiggle room both in what "in sync" and+-- "visible" means and how they propagate through time. ----- E.g., @UpdDisplaceActor@ in a black room,--- with one actor carrying a 0-radius light would not be+-- E.g., @UpdDisplaceActor@ in a black room between two enemy actors,+-- with only one actor carrying a 0-radius light would not be -- distinguishable by looking at the state (or the screen) from @UpdMoveActor@ -- of the illuminated actor, hence such @UpdDisplaceActor@ should not be--- observable, but @UpdMoveActor@ should be (or the former should be perceived--- as the latter). However, to simplify, we assign as strict visibility+-- observable, but @UpdMoveActor@ in similar cotext would be+-- (or the former should be perceived as the latter).+-- However, to simplify, we assign as strict visibility -- requirements to @UpdMoveActor@ as to @UpdDisplaceActor@ and fall back -- to @UpdSpotActor@ (which provides minimal information that does not -- contradict state) if the visibility is lower.@@ -71,6 +81,8 @@   UpdLoseActor _ body _ -> return $! posProjBody body   UpdSpotItem _ _ _ _ c -> singleContainer c   UpdLoseItem _ _ _ _ c -> singleContainer c+  UpdSpotItemBag c _ _ -> singleContainer c+  UpdLoseItemBag c _ _ -> singleContainer c   UpdMoveActor aid fromP toP -> do     b <- getsState $ getActorBody aid     -- Non-projectile actors are never totally isolated from envirnoment;@@ -125,14 +137,15 @@   UpdCoverKind c _ _ -> singleContainer c   UpdDiscoverSeed c _ _ -> singleContainer c   UpdCoverSeed c _ _ -> singleContainer c+  UpdDiscoverServer{} -> return PosSer+  UpdCoverServer{} -> return PosSer   UpdPerception{} -> return PosNone-  UpdRestart fid _ _ _ _ _ -> return $! PosFid fid+  UpdRestart fid _ _ _ _ -> return $! PosFid fid   UpdRestartServer _ -> return PosSer   UpdResume _ _ -> return PosNone   UpdResumeServer _ -> return PosSer   UpdKillExit fid -> return $! PosFid fid   UpdWriteSave -> return PosAll-  UpdMsgAll{} -> return PosAll  -- | Produce the positions where the atomic special effect takes place. posSfxAtomic :: MonadStateRead m => SfxAtomic -> m PosAtomic@@ -161,6 +174,7 @@     else return $! PosFidAndSight [bfid body] (blid body) [bpos body, p]   SfxEffect _ aid _ _ -> singleAid aid  -- sometimes we don't see source, OK   SfxMsgFid fid _ -> return $! PosFid fid+  SfxSortSlots -> return PosAll  posProjBody :: Actor -> PosAtomic posProjBody body =@@ -191,23 +205,25 @@ singleContainer (CTrunk fid lid p) =   return $! PosFidAndSight [fid] lid [p] --- | Decompose an atomic action. The decomposed actions give reduced--- information that still modifies client's state to match the server state--- wrt the current FOV and the subset of @posUpdAtomic@ that is visible.--- The original actions give more information not only due to spanning--- potentially more positions than those visible. E.g., @UpdMoveActor@+-- | Decompose an atomic action that is outside a client's visiblity.+-- The decomposed actions give less information that the original command,+-- but some of them may fall within the visibility range of the client.+-- The original action may give more information than even the total sum+-- of all actions it's broken into. E.g., @UpdMoveActor@ -- informs about the continued existence of the actor between--- moves, v.s., popping out of existence and then back in.+-- moves vs popping out of existence and then back in.+--+-- This is computed in server's @State@ from before performing the command. breakUpdAtomic :: MonadStateRead m => UpdAtomic -> m [UpdAtomic] breakUpdAtomic cmd = case cmd of-  UpdMoveActor aid _ toP -> do+  UpdMoveActor aid fromP toP -> do     -- We assume other factions don't see leaders and we know the actor's     -- faction always sees the atomic command, so the leader doesn't     -- need to be updated (or the actor is a projectile, hence not a leader).     b <- getsState $ getActorBody aid     ais <- getsState $ getCarriedAssocs b     return [ UpdLoseActor aid b ais-           , UpdSpotActor aid b {bpos = toP, boldpos = Just $ bpos b} ais ]+           , UpdSpotActor aid b {bpos = toP, boldpos = Just fromP} ais ]   UpdDisplaceActor source target -> do     sb <- getsState $ getActorBody source     sais <- getsState $ getCarriedAssocs sb@@ -222,7 +238,7 @@            ]   _ -> return [] --- | Given the client, it's perception and an atomic command, determine+-- | Given the client, its perception and an atomic command, determine -- if the client notices the command. seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool seenAtomicCli knowEvents fid per posAtomic =@@ -237,34 +253,11 @@     PosAll -> True     PosNone -> error $ "no position possible" `showFailure` fid --- Not needed ATM, but may be a coincidence.+-- | Determine whether the server would see a command that has+-- the given visibilty conditions. seenAtomicSer :: PosAtomic -> Bool seenAtomicSer posAtomic =   case posAtomic of     PosFid _ -> False     PosNone -> error $ "no position possible" `showFailure` posAtomic     _ -> True---- | Generate the atomic updates that jointly perform a given item move.-generalMoveItem :: MonadStateRead m-                => Bool -> ItemId -> Int -> Container -> Container-                -> m [UpdAtomic]-generalMoveItem verbose iid k c1 c2 =-  case (c1, c2) of-    (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2-                                                 && cstore1 /= CSha-                                                 && cstore2 /= CSha ->-      return [UpdMoveItem iid k aid1 cstore1 cstore2]-    _ -> containerMoveItem verbose iid k c1 c2--containerMoveItem :: MonadStateRead m-                  => Bool -> ItemId -> Int -> Container -> Container-                  -> m [UpdAtomic]-containerMoveItem verbose iid k c1 c2 = do-  bag <- getsState $ getContainerBag c1-  case iid `EM.lookup` bag of-    Nothing -> error $ "" `showFailure` (iid, k, c1, c2)-    Just (_, it) -> do-      item <- getsState $ getItemBody iid-      return [ UpdLoseItem verbose iid item (k, take k it) c1-             , UpdSpotItem verbose iid item (k, take k it) c2 ]

@@ -1,16 +1,29 @@--- | Semantics of responses that are sent to clients.+-- | Semantics of responses that are sent from server to clients,+-- in terms of client state transformations,+-- and semantics of human commands and AI moves, in terms of requests+-- to be sent from the client to the server. -- -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Client   ( -- * Re-exported from "Game.LambdaHack.Client.LoopM"     loopCli+    -- * Re-exported from "Game.LambdaHack.Client.Request"+  , RequestAI, ReqAI(..), RequestUI, ReqUI(..)+  , RequestAnyAbility(..), RequestTimed(..)+    -- * Re-exported from "Game.LambdaHack.Client.Response"+  , Response (..)+    -- * Re-exported from "Game.LambdaHack.Client.ClientOptions"+  , ClientOptions, defClientOptions, sbenchmark     -- * Re-exported from "Game.LambdaHack.Client.UI"-  , KeyKind, SessionUI, emptySessionUI-  , Config, applyConfigToDebug, configCmdline, mkConfig+  , KeyKind+  , UIOptions, applyUIOptions, uCmdline, mkUIOptions   ) where  import Prelude () +import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.LoopM+import Game.LambdaHack.Client.Request+import Game.LambdaHack.Client.Response import Game.LambdaHack.Client.UI

@@ -5,7 +5,7 @@   ( queryAI #ifdef EXPOSE_INTERNAL     -- * Internal operations-  , pickAI, pickAction, udpdateCondInMelee, condInMeleeM+  , pickActorAndAction, udpdateCondInMelee #endif   ) where @@ -17,57 +17,56 @@  import Game.LambdaHack.Client.AI.HandleAbilityM import Game.LambdaHack.Client.AI.PickActorM-import Game.LambdaHack.Client.AI.Strategy import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.Request import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State --- | Handle the move of an actor under AI control (of UI or AI player).+-- | Handle the move of an actor under AI control (regardless if the whole+-- faction is under human or computer control). queryAI :: MonadClient m => ActorId -> m RequestAI queryAI aid = do-  -- @_sleader@ may be different from @_gleader@ due to @stopPlayBack@,+  -- @sleader@ may be different from @gleader@ due to @stopPlayBack@,   -- but only leaders may change faction leader, so we fix that:   side <- getsClient sside-  mleader <- getsState $ _gleader . (EM.! side) . sfactionD-  mleaderCli <- getsClient _sleader+  mleader <- getsState $ gleader . (EM.! side) . sfactionD+  mleaderCli <- getsClient sleader   unless (Just aid == mleader || mleader == mleaderCli) $     -- @aid@ is not the leader, so he can't change leader     modifyClient $ \cli -> cli {_sleader = mleader}-  -- @condInMelee@ will most proably be needed in this functions,+  -- @condInMelee@ will most proably be needed in the following functions,   -- but even if not, it's OK, it's not forced, because wrapped in @Maybe@:   udpdateCondInMelee aid-  (aidToMove, treq) <- pickAI Nothing aid+  (aidToMove, treq) <- pickActorAndAction Nothing aid   (aidToMove2, treq2) <-     case treq of       RequestAnyAbility ReqWait | mleader == Just aid -> do         -- leader waits; a waste; try once to pick a yet different leader         modifyClient $ \cli -> cli {_sleader = mleader}  -- undo previous choice-        pickAI (Just (aidToMove, treq)) aid+        pickActorAndAction (Just (aidToMove, treq)) aid       _ -> return (aidToMove, treq)   return ( ReqAITimed treq2          , if aidToMove2 /= aid then Just aidToMove2 else Nothing ) -pickAI :: MonadClient m-       => Maybe (ActorId, RequestAnyAbility) -> ActorId-       -> m (ActorId, RequestAnyAbility)+-- | Pick an actor to move and an action for him to perform, given an optional+-- previous candidate actor and action and the server-proposed actor.+pickActorAndAction :: MonadClient m+                     => Maybe (ActorId, RequestAnyAbility) -> ActorId+                     -> m (ActorId, RequestAnyAbility) -- This inline speeds up execution by 10% and increases allocation by 15%, -- despite probably bloating executable:-{-# INLINE pickAI #-}-pickAI maid aid = do-  mleader <- getsClient _sleader+{-# INLINE pickActorAndAction #-}+pickActorAndAction maid aid = do+  mleader <- getsClient sleader   aidToMove <-     if mleader == Just aid     then pickActorToMove (fst <$> maid)     else do-      useTactics aid+      setTargetFromTactics aid       return aid   treq <- case maid of     Just (aidOld, treqOld) | aidToMove == aidOld ->@@ -75,26 +74,11 @@     _ -> pickAction aidToMove (isJust maid)   return (aidToMove, treq) --- | Pick an action the actor will perform this turn.-pickAction :: MonadClient m => ActorId -> Bool -> m RequestAnyAbility-{-# INLINE pickAction #-}-pickAction aid retry = do-  side <- getsClient sside-  body <- getsState $ getActorBody aid-  let !_A = assert (bfid body == side-                    `blame` "AI tries to move enemy actor"-                    `swith` (aid, bfid body, side)) ()-  let !_A = assert (isNothing (btrajectory body)-                    `blame` "AI gets to manually move its projectiles"-                    `swith` (aid, bfid body, side)) ()-  stratAction <- actionStrategy aid retry-  let bestAction = bestVariant stratAction-      !_A = assert (not (nullFreq bestAction)  -- equiv to nullStrategy-                    `blame` "no AI action for actor"-                    `swith` (stratAction, aid, body)) ()-  -- Run the AI: chose an action from those given by the AI strategy.-  rndToAction $ frequency bestAction-+-- | Check if any non-dying foe (projectile or not) is adjacent+-- to any of our normal actors (whether they can melee or just need to flee,+-- in which case alert is needed so that they are not slowed down by others)+-- and record this per-level. This is needed only by AI and computed+-- as lazily as possible before each round of AI deliberations. udpdateCondInMelee :: MonadClient m => ActorId -> m () udpdateCondInMelee aid = do   b <- getsState $ getActorBody aid@@ -102,26 +86,8 @@   case condInMelee of     Just{} -> return ()  -- still up to date     Nothing -> do-      newCond <- condInMeleeM b  -- lazy and kept that way due to @Maybe@+      newCond <- getsState $ inMelee b+        -- lazy and kept that way due to @Maybe@       modifyClient $ \cli ->         cli {scondInMelee =                EM.adjust (const $ Just newCond) (blid b) (scondInMelee cli)}---- | Check if any non-dying foe (projectile or not) is adjacent--- to any of our normal actors (whether they can melee or just need to flee,--- in which case alert is needed so that they are not slowed down by others).-condInMeleeM :: MonadClient m => Actor -> m Bool-condInMeleeM bodyOur = do-  fact <- getsState $ (EM.! bfid bodyOur) . sfactionD-  let f !b = blid b == blid bodyOur && isAtWar fact (bfid b) && bhp b > 0-  -- We assume foes are less numerous, because usually they are heroes,-  -- and so we compute them once and use many times.-  -- For the same reason @anyFoeAdj@ would not speed up this computation-  -- in normal gameplay (as opposed to AI vs AI benchmarks).-  allFoes <- getsState $ filter f . EM.elems . sactorD-  getsState $ any (\body ->-    bfid bodyOur == bfid body-    && blid bodyOur == blid body-    && not (bproj body)-    && bhp body > 0-    && any (\b -> adjacent (bpos b) (bpos body)) allFoes) . sactorD

@@ -1,23 +1,22 @@--- | Semantics of abilities in terms of actions and the AI procedure--- for picking the best action for an actor.+-- | Assorted conditions used later on in AI logic. module Game.LambdaHack.Client.AI.ConditionM   ( condAimEnemyPresentM   , condAimEnemyRememberedM   , condTgtNonmovingM   , condAnyFoeAdjM   , condAdjTriggerableM+  , meleeThreatDistList   , condBlocksFriendsM   , condFloorWeaponM   , condNoEqpWeaponM   , condCanProjectM   , condProjectListM-  , condDesirableFloorItemM-  , condSupport   , benAvailableItems   , hinders+  , condDesirableFloorItemM   , benGroundItems   , desirableItem-  , meleeThreatDistList+  , condSupport   , condShineWouldBetrayM   , fleeList   ) where@@ -27,29 +26,29 @@ import Game.LambdaHack.Common.Prelude  import qualified Data.EnumMap.Strict as EM-import Data.Ord+import           Data.Ord -import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.CommonM-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Content.ModeKind  -- All conditions are (partially) lazy, because they are not always -- used in the strict monadic computations they are in.@@ -103,9 +102,10 @@ -- so to resolve the stalemate, the opposing AI has to be aggresive -- by ignoring them and then when melee is started, it's usually too late -- to retreat.-meleeThreatDistList :: MonadClient m => ActorId -> m [(Int, (ActorId, Actor))]+meleeThreatDistList :: MonadStateRead m+                    => ActorId -> m [(Int, (ActorId, Actor))] meleeThreatDistList aid = do-  actorAspect <- getsClient sactorAspect+  actorAspect <- getsState sactorAspect   b <- getsState $ getActorBody aid   fact <- getsState $ (EM.! bfid b) . sfactionD   allAtWar <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)@@ -132,14 +132,14 @@   return $ any blocked ours  -- | Require the actor stands over a weapon that would be auto-equipped.-condFloorWeaponM :: MonadClient m => ActorId -> m Bool+condFloorWeaponM :: MonadStateRead m => ActorId -> m Bool condFloorWeaponM aid = do   floorAssocs <- getsState $ getActorAssocs aid CGround   let lootIsWeapon = any (isMelee . snd) floorAssocs   return lootIsWeapon  -- | Check whether the actor has no weapon in equipment.-condNoEqpWeaponM :: MonadClient m => ActorId -> m Bool+condNoEqpWeaponM :: MonadStateRead m => ActorId -> m Bool condNoEqpWeaponM aid = do   eqpAssocs <- getsState $ getActorAssocs aid CEqp   return $ all (not . isMelee . snd) eqpAssocs@@ -159,9 +159,8 @@   b <- getsState $ getActorBody aid   condShineWouldBetray <- condShineWouldBetrayM aid   condAimEnemyPresent <- condAimEnemyPresentM aid-  actorAspect <- getsClient sactorAspect-  let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect)-      calmE = calmEnough b ar+  ar <- getsState $ getActorAspect aid+  let calmE = calmEnough b ar       condNotCalmEnough = not calmE       heavilyDistressed =  -- Actor hit by a projectile or similarly distressed.         deltaSerious (bcalmDelta b)@@ -186,7 +185,7 @@                   => ActorId -> [CStore]                   -> m [(Maybe Benefit, CStore, ItemId, ItemFull)] benAvailableItems aid cstores = do-  itemToF <- itemToFullClient+  itemToF <- getsState itemToFull   b <- getsState $ getActorBody aid   discoBenefit <- getsClient sdiscoBenefit   s <- getState@@ -238,7 +237,7 @@   benList <- benAvailableItems aid [CGround]   return $ filter isDesirable benList -desirableItem :: Bool -> Maybe Int -> Item -> Bool+desirableItem :: Bool -> Maybe Double -> Item -> Bool desirableItem canEsc mpickupSum item =   if canEsc   then fromMaybe 10 mpickupSum > 0@@ -253,7 +252,7 @@  condSupport :: MonadClient m => Int -> ActorId -> m Bool condSupport param aid = do-  actorAspect <- getsClient sactorAspect+  actorAspect <- getsState sactorAspect   b <- getsState $ getActorBody aid   btarget <- getsClient $ getTarget aid   mtgtPos <- case btarget of@@ -274,14 +273,14 @@       closeAndStrong (aid2, b2) = closeEnough b2                                   && actorCanMelee actorAspect aid2 b2       closeAndStrongFriends = filter closeAndStrong friends-      -- The smaller area scanned for friends, the lower number required.-      suport = length closeAndStrongFriends >= param - aAggression ar+      -- The smaller the area scanned for friends, the lower number required.+      suport = length closeAndStrongFriends >= min 2 param - aAggression ar                || length friends <= 1  -- solo fighters aggresive   return suport  -- | Require that the actor stands in the dark and so would be betrayed -- by his own equipped light,-condShineWouldBetrayM :: MonadClient m => ActorId -> m Bool+condShineWouldBetrayM :: MonadStateRead m => ActorId -> m Bool condShineWouldBetrayM aid = do   b <- getsState $ getActorBody aid   aInAmbient <- getsState $ actorInAmbient b

@@ -1,14 +1,13 @@ {-# LANGUAGE DataKinds #-}--- | Semantics of abilities in terms of actions and the AI procedure--- for picking the best action for an actor.+-- | AI procedure for picking the best action for an actor. module Game.LambdaHack.Client.AI.HandleAbilityM-  ( actionStrategy+  ( pickAction #ifdef EXPOSE_INTERNAL     -- * Internal operations-  , ApplyItemGroup+  , actionStrategy   , waitBlockNow, pickup, equipItems, toShare, yieldUnneeded, unEquipItems   , groupByEqpSlot, bestByEqpSlot, harmful, meleeBlocker, meleeAny-  , trigger, projectItem, applyItem, flee+  , trigger, projectItem, ApplyItemGroup, applyItem, flee   , displaceFoe, displaceBlocker, displaceTowards   , chase, moveTowards, moveOrRunAid #endif@@ -20,44 +19,66 @@  import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import Data.Function-import Data.Ord-import Data.Ratio+import           Data.Function+import           Data.Ord+import           Data.Ratio -import Game.LambdaHack.Client.AI.ConditionM-import Game.LambdaHack.Client.AI.Strategy-import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.BfsM-import Game.LambdaHack.Client.CommonM-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest+import           Game.LambdaHack.Client.AI.ConditionM+import           Game.LambdaHack.Client.AI.Strategy+import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.BfsM+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.Request+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Common.Ability+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Frequency+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Random+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Content.ModeKind +-- | Pick the most desirable AI ation for the actor.+pickAction :: MonadClient m => ActorId -> Bool -> m RequestAnyAbility+{-# INLINE pickAction #-}+pickAction aid retry = do+  side <- getsClient sside+  body <- getsState $ getActorBody aid+  let !_A = assert (bfid body == side+                    `blame` "AI tries to move enemy actor"+                    `swith` (aid, bfid body, side)) ()+  let !_A = assert (isNothing (btrajectory body)+                    `blame` "AI gets to manually move its projectiles"+                    `swith` (aid, bfid body, side)) ()+  stratAction <- actionStrategy aid retry+  let bestAction = bestVariant stratAction+      !_A = assert (not (nullFreq bestAction)  -- equiv to nullStrategy+                    `blame` "no AI action for actor"+                    `swith` (stratAction, aid, body)) ()+  -- Run the AI: chose an action from those given by the AI strategy.+  rndToAction $ frequency bestAction+ type ToAny a = Strategy (RequestTimed a) -> Strategy RequestAnyAbility  toAny :: ToAny a toAny strat = RequestAnyAbility <$> strat --- | AI strategy based on actor's sight, smell, etc.+-- AI strategy based on actor's sight, smell, etc. -- Never empty. actionStrategy :: forall m. MonadClient m                => ActorId -> Bool -> m (Strategy RequestAnyAbility)@@ -73,7 +94,7 @@   threatDistL <- meleeThreatDistList aid   (fleeL, badVic) <- fleeList aid   condSupport1 <- condSupport 1 aid-  condSupport2 <- condSupport 2 aid+  condSupport3 <- condSupport 3 aid   canDeAmbientL <- getsState $ canDeAmbientList body   actorSk <- currentSkillsClient aid   condCanProject <-@@ -86,8 +107,8 @@   condDesirableFloorItem <- condDesirableFloorItemM aid   condTgtNonmoving <- condTgtNonmovingM aid   explored <- getsClient sexplored-  actorAspect <- getsClient sactorAspect-  let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect)+  actorAspect <- getsState sactorAspect+  let ar = actorAspect EM.! aid       lidExplored = ES.member (blid body) explored       panicFleeL = fleeL ++ badVic       condHpTooLow = hpTooLow body ar@@ -95,7 +116,6 @@       speed1_5 = speedScale (3%2) (bspeed body ar)       condCanMelee = actorCanMelee actorAspect aid body       condMeleeBad1 = not (condSupport1 && condCanMelee)-      condMeleeBad2 = not (condSupport2 && condCanMelee)       condThreat n = not $ null $ takeWhile ((<= n) . fst) threatDistL       threatAdj = takeWhile ((== 1) . fst) threatDistL       condManyThreatAdj = length threatAdj >= 2@@ -134,7 +154,7 @@               -- in the latter case, may return via different stairs later on           , condAdjTriggerable && not condAimEnemyPresent             && ((condNotCalmEnough || condHpTooLow)  -- flee-                && condMeleeBad2 && condThreat 1+                && condMeleeBad1 && condThreat 1                 || (lidExplored || condEnoughGear)  -- explore                    && not condDesirableFloorItem) )         , ( [AbDisplace]@@ -163,7 +183,7 @@                     -- to enemy to get out of his range, most likely,                     -- and so melee him instead, unless can't melee at all.                     not condCanMelee-                    || not condSupport2 && not heavilyDistressed+                    || not condSupport3 && not heavilyDistressed                   | condThreat 5 ->                     -- Too far to flee from melee, too close from ranged,                     -- not in ambient, so no point fleeing into dark; advance.@@ -290,7 +310,6 @@   sumFallback <- sumS fallback   return $! sumPrefix .| comDistant .| sumSuffix .| sumFallback --- | A strategy to always just wait. waitBlockNow :: MonadClient m => m (Strategy (RequestTimed 'AbWait)) waitBlockNow = return $! returN "wait" ReqWait @@ -306,9 +325,8 @@   -- The calmE is inaccurate also if an item not IDed, but that's intended   -- and the server will ignore and warn (and content may avoid that,   -- e.g., making all rings identified)-  actorAspect <- getsClient sactorAspect-  let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect)-      calmE = calmEnough b ar+  ar <- getsState $ getActorAspect aid+  let calmE = calmEnough b ar       isWeapon (_, _, _, itemFull) = isMelee $ itemBase itemFull       filterWeapon | onlyWeapon = filter isWeapon                    | otherwise = id@@ -338,12 +356,11 @@            => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) equipItems aid = do   body <- getsState $ getActorBody aid-  actorAspect <- getsClient sactorAspect-  let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect)-      calmE = calmEnough body ar-  eqpAssocs <- fullAssocsClient aid [CEqp]-  invAssocs <- fullAssocsClient aid [CInv]-  shaAssocs <- fullAssocsClient aid [CSha]+  ar <- getsState $ getActorAspect aid+  let calmE = calmEnough body ar+  eqpAssocs <- getsState $ fullAssocs aid [CEqp]+  invAssocs <- getsState $ fullAssocs aid [CInv]+  shaAssocs <- getsState $ fullAssocs aid [CSha]   condShineWouldBetray <- condShineWouldBetrayM aid   condAimEnemyPresent <- condAimEnemyPresentM aid   discoBenefit <- getsClient sdiscoBenefit@@ -401,10 +418,9 @@               => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) yieldUnneeded aid = do   body <- getsState $ getActorBody aid-  actorAspect <- getsClient sactorAspect-  let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect)-      calmE = calmEnough body ar-  eqpAssocs <- fullAssocsClient aid [CEqp]+  ar <- getsState $ getActorAspect aid+  let calmE = calmEnough body ar+  eqpAssocs <- getsState $ fullAssocs aid [CEqp]   condShineWouldBetray <- condShineWouldBetrayM aid   condAimEnemyPresent <- condAimEnemyPresentM aid   discoBenefit <- getsClient sdiscoBenefit@@ -439,12 +455,11 @@              => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) unEquipItems aid = do   body <- getsState $ getActorBody aid-  actorAspect <- getsClient sactorAspect-  let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect)-      calmE = calmEnough body ar-  eqpAssocs <- fullAssocsClient aid [CEqp]-  invAssocs <- fullAssocsClient aid [CInv]-  shaAssocs <- fullAssocsClient aid [CSha]+  ar <- getsState $ getActorAspect aid+  let calmE = calmEnough body ar+  eqpAssocs <- getsState $ fullAssocs aid [CEqp]+  invAssocs <- getsState $ fullAssocs aid [CInv]+  shaAssocs <- getsState $ fullAssocs aid [CSha]   discoBenefit <- getsClient sdiscoBenefit   let improve :: CStore -> ( IK.EqpSlot                            , ( [(Int, (ItemId, ItemFull))]@@ -533,8 +548,8 @@ meleeBlocker :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMelee)) meleeBlocker aid = do   b <- getsState $ getActorBody aid-  actorAspect <- getsClient sactorAspect-  let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect)+  actorAspect <- getsState sactorAspect+  let ar = actorAspect EM.! aid   fact <- getsState $ (EM.! bfid b) . sfactionD   actorSk <- currentSkillsClient aid   mtgtMPath <- getsClient $ EM.lookup aid . stargetD@@ -553,8 +568,7 @@         Just aim -> getsState $ posToAssocs aim (blid b)       case lBlocker of         (aid2, body2) : _ -> do-          let ar2 = fromMaybe (error $ "" `showFailure` aid2)-                              (EM.lookup aid2 actorAspect)+          let ar2 = actorAspect EM.! aid2           -- No problem if there are many projectiles at the spot. We just           -- attack the first one.           if | actorDying body2@@ -596,7 +610,7 @@   let freq = uniformFreq "melee adjacent" $ catMaybes mels   return $! liftFrequency freq --- | The level the actor is on is either explored or the actor already+-- The level the actor is on is either explored or the actor already -- has a weapon equipped, so no need to explore further, he tries to find -- enemies on other levels. -- We don't verify any embedded item is targeted by the actor, but at least@@ -613,7 +627,7 @@       pbags = mapMaybe f $ vicinityUnsafe (bpos b)   efeat <- embedBenefit fleeVia aid pbags   return $! liftFrequency $ toFreq "trigger"-    [ (benefit, ReqAlter pos)+    [ (ceiling benefit, ReqAlter pos)     | (benefit, (pos, _)) <- efeat ]  projectItem :: MonadClient m@@ -658,7 +672,7 @@                                Nothing -> -10  -- experiment if no good options                                Just Benefit{benFling} -> benFling                 in if trange >= chessDist (bpos b) fpos && recharged-                   then Just ( - benR * rangeMult `div` 10+                   then Just ( - ceiling (benR * fromIntegral rangeMult / 10)                              , ReqProject fpos newEps iid cstore )                    else Nothing               benRanged = mapMaybe fRanged benList@@ -677,9 +691,8 @@   condShineWouldBetray <- condShineWouldBetrayM aid   condAimEnemyPresent <- condAimEnemyPresentM aid   localTime <- getsState $ getLocalTime (blid b)-  actorAspect <- getsClient sactorAspect-  let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect)-      calmE = calmEnough b ar+  ar <- getsState $ getActorAspect aid+  let calmE = calmEnough b ar       condNotCalmEnough = not calmE       heavilyDistressed =  -- Actor hit by a projectile or similarly distressed.         deltaSerious (bcalmDelta b)@@ -715,7 +728,7 @@                                    then Just $ toGroupName $ jname item                                    else Nothing) organs       itemLegal itemFull =-        -- Don't include @Ascend@ not @Teleport@, because can be no foe nearby.+        -- Don't include @Ascend@ nor @Teleport@, because can be no foe nearby.         let getP (IK.RefillHP p) | p > 0 = True             getP _ = False             firstAidItem = case itemDisco itemFull of@@ -736,7 +749,7 @@               -- This assumes the organ dropping is beneficial and so worth               -- saving for the future, for otherwise the item would not               -- be considered at all, given that it's the only effect.-              -- We don't try to intecept a case of many effects.+              -- We don't try to intercept the case of many effects.               let dropsGrps = strengthDropOrgan itemFull                   hasDropOrgan = not $ null dropsGrps                   f eff = [eff | IK.forApplyEffect eff]@@ -751,7 +764,7 @@                 -- experimenting is fun, but it's better to risk                 -- foes' skin than ours               Just Benefit{benApply} ->-                benApply+                ceiling benApply                 * if cstore == CEqp && not durable                   then 100000  -- must hinder currently                   else coeff cstore@@ -829,7 +842,7 @@   if boldpos b /= Just target -- avoid trivial loops      && Tile.isWalkable coTileSpeedup (lvl `at` target) then do        -- DisplaceAccess-    mleader <- getsClient _sleader+    mleader <- getsClient sleader     mBlocker <- getsState $ posToAssocs target (blid b)     case mBlocker of       [] -> return reject@@ -870,6 +883,8 @@   mtgtMPath <- getsClient $ EM.lookup aid . stargetD   lvl <- getLevel $ blid body   let isAmbient pos = Tile.isLit coTileSpeedup (lvl `at` pos)+                      && Tile.isWalkable coTileSpeedup (lvl `at` pos)+                        -- if solid, will be altered and perhaps darkened   str <- case mtgtMPath of     Just TgtAndPath{tapPath=AndPath{pathList=q : _, ..}}       | pathGoal == bpos body -> return reject  -- shortcut and just to be sure@@ -918,7 +933,7 @@         freqs = map (liftFrequency . uniformFreq "moveTowards") groups     return $! foldr (.|) reject freqs --- | Actor moves or searches or alters or attacks.+-- Actor moves or searches or alters or attacks. -- This function is very general, even though it's often used in contexts -- when only one or two of the many cases can possibly occur. moveOrRunAid :: MonadClient m

@@ -1,6 +1,6 @@--- | Semantics of most 'ResponseAI' client commands.+-- | Picking the AI actor to move and refreshing leader and non-leader targets. module Game.LambdaHack.Client.AI.PickActorM-  ( pickActorToMove, useTactics+  ( pickActorToMove, setTargetFromTactics   ) where  import Prelude ()@@ -8,7 +8,7 @@ import Game.LambdaHack.Common.Prelude  import qualified Data.EnumMap.Strict as EM-import Data.Ratio+import           Data.Ratio  import Game.LambdaHack.Client.AI.ConditionM import Game.LambdaHack.Client.AI.PickTargetM@@ -29,13 +29,13 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ModeKind --- Pick a new leader from among the actors on the current level.+-- | Pick a new leader from among the actors on the current level. -- Refresh the target of the new leader, even if unchanged. pickActorToMove :: MonadClient m => Maybe ActorId -> m ActorId {-# INLINE pickActorToMove #-} pickActorToMove maidToAvoid = do-  actorAspect <- getsClient sactorAspect-  mleader <- getsClient _sleader+  actorAspect <- getsState sactorAspect+  mleader <- getsClient sleader   let oldAid = fromMaybe (error $ "" `showFailure` maidToAvoid) mleader   oldBody <- getsState $ getActorBody oldAid   let side = bfid oldBody@@ -89,10 +89,10 @@               Just ((aid, b), tgt)             _ -> Nothing       oursTgtRaw <- mapM refresh ours+      scondInMelee <- getsClient scondInMelee       let oursTgt = mapMaybe goodGeneric oursTgtRaw           -- This should be kept in sync with @actionStrategy@.           actorVulnerable ((aid, body), _) = do-            scondInMelee <- getsClient scondInMelee             let condInMelee = fromMaybe (error $ "" `showFailure` condInMelee)                                         (scondInMelee EM.! blid body)                 ar = fromMaybe (error $ "" `showFailure` aid)@@ -100,7 +100,7 @@             threatDistL <- meleeThreatDistList aid             (fleeL, _) <- fleeList aid             condSupport1 <- condSupport 1 aid-            condSupport2 <- condSupport 2 aid+            condSupport3 <- condSupport 3 aid             canDeAmbientL <- getsState $ canDeAmbientList body             let condCanFlee = not (null fleeL)                 speed1_5 = speedScale (3%2) (bspeed body ar)@@ -122,13 +122,14 @@                 canFleeFromLight =                   not $ null $ aCanDeLightL `intersect` map snd fleeL             return $!+              -- This is a part of the condition for @flee@ in @HandleAbilityM@.               not condFastThreatAdj               && if | condThreat 1 -> not condCanMelee                                       || condManyThreatAdj && not condSupport1                     | not condInMelee                       && (condThreat 2 || condThreat 5 && canFleeFromLight) ->                       not condCanMelee-                      || not condSupport2 && not heavilyDistressed+                      || not condSupport3 && not heavilyDistressed                     -- not used: | condThreat 5 -> False                     -- because actor should be picked anyway, to try to melee                     | otherwise ->@@ -259,21 +260,29 @@         l : _ -> do           let freq = toFreq "candidates for AI leader"                      $ map (positiveOverhead &&& id) l-          ((aid, _), _) <- rndToAction $ frequency freq+          ((aid, b), _) <- rndToAction $ frequency freq           s <- getState           modifyClient $ updateLeader aid s+          -- When you become a leader, stop following old leader, but follow+          -- his target, if still valid, to avoid distraction.+          let condInMelee = fromMaybe (error $ "" `showFailure` condInMelee)+                                      (scondInMelee EM.! blid b)+          when (ftactic (gplayer fact) `elem` [TFollow, TFollowNoItems]+                && not condInMelee) $+            void $ refreshTarget (aid, b)           return aid         _ -> return oldAid -useTactics :: MonadClient m => ActorId -> m ()-{-# INLINE useTactics #-}-useTactics oldAid = do+-- | Inspect the tactics of the actor and set his target according to it.+setTargetFromTactics :: MonadClient m => ActorId -> m ()+{-# INLINE setTargetFromTactics #-}+setTargetFromTactics oldAid = do+  mleader <- getsClient sleader+  let !_A = assert (mleader /= Just oldAid) ()   oldBody <- getsState $ getActorBody oldAid   scondInMelee <- getsClient scondInMelee   let condInMelee = fromMaybe (error $ "" `showFailure` condInMelee)                               (scondInMelee EM.! blid oldBody)-  mleader <- getsClient _sleader-  let !_A = assert (mleader /= Just oldAid) ()   let side = bfid oldBody       arena = blid oldBody   fact <- getsState $ (EM.! side) . sfactionD

@@ -15,33 +15,33 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import Game.LambdaHack.Client.AI.ConditionM-import Game.LambdaHack.Client.AI.Strategy-import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.BfsM-import Game.LambdaHack.Client.CommonM-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Item+import           Game.LambdaHack.Client.AI.ConditionM+import           Game.LambdaHack.Client.AI.Strategy+import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.BfsM+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Common.Ability+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Frequency+import           Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Random+import           Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.TileKind (isUknownSpace)+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Content.RuleKind+import           Game.LambdaHack.Content.TileKind (isUknownSpace)  -- | Verify and possibly change the target of an actor. This function both -- updates the target in the client state and returns the new target explicitly.@@ -87,12 +87,12 @@ targetStrategy aid = do   Kind.COps{corule, coTileSpeedup} <- getsState scops   b <- getsState $ getActorBody aid-  mleader <- getsClient _sleader+  mleader <- getsClient sleader   scondInMelee <- getsClient scondInMelee   salter <- getsClient salter   -- We assume the actor eventually becomes a leader (or has the same   -- set of abilities as the leader, anyway) and set his target accordingly.-  actorAspect <- getsClient sactorAspect+  actorAspect <- getsState sactorAspect   let lalter = salter EM.! blid b       condInMelee = fromMaybe (error $ "" `showFailure` condInMelee)                               (scondInMelee EM.! blid b)@@ -145,7 +145,7 @@                 -- Needed for now, because AI targets and shoots enemies                 -- based on the path to them, not LOS to them:                 || EM.findWithDefault 0 AbProject actorMaxSk > 0-  actorMinSk <- getsState $ actorSkills Nothing aid ar+  actorMinSk <- getsState $ actorSkills Nothing aid   condCanProject <-     condCanProjectM (EM.findWithDefault 0 AbProject actorMaxSk) aid   condEnoughGear <- condEnoughGearM aid@@ -316,6 +316,9 @@         pickNewTarget       tileAdj :: (Point -> Bool) -> Point -> Bool       tileAdj f p = any f $ vicinityUnsafe p+      followingWrong permit =+        permit && (condInMelee  -- in melee, stop following+                   || mleader == Just aid) -- a leader, never follow       updateTgt :: TgtAndPath -> m (Strategy TgtAndPath)       updateTgt TgtAndPath{tapPath=NoPath} = pickNewTarget       updateTgt tap@TgtAndPath{tapPath=AndPath{..},tapTgt} = case tapTgt of@@ -325,11 +328,9 @@                 || not focused && not (null nearbyFoes))  -- prefers closer foes                && a `notElem` map fst nearbyFoes  -- old one not close enough                || blid body /= blid b  -- wrong level-               || actorDying body  -- foe already dying-               || permit-                  && (condInMelee  -- in melee, stop following-                      || mleader == Just aid) ->  -- a leader, never follow+               || actorDying body -> -- foe already dying                pickNewTarget+             | followingWrong permit -> pickNewTarget              | bpos body == pathGoal ->                return $! returN "TEnemy" tap                  -- The enemy didn't move since the target acquired.@@ -356,10 +357,7 @@             pickNewTarget  -- prefer close foes to anything else           TEnemyPos _ permit  -- chase last position even if foe hides             | bpos b == pos -> tellOthersNothingHere pos-            | permit-              && (condInMelee  -- in melee, stop following-                  || mleader == Just aid) ->  -- a leader, never follow-              pickNewTarget  -- melee, stop following+            | followingWrong permit -> pickNewTarget             | otherwise -> return $! returN "TEnemyPos" tap           -- Below we check the target could not be picked again in           -- pickNewTarget (e.g., an item got picked up by our teammate)@@ -395,13 +393,15 @@                      -- to enable pickup; if pickup fails, will retarget                | otherwise -> return $! returN "TItem" tap           TSmell ->-            if not canSmell-               || let sml = EM.findWithDefault timeZero pos (lsmell lvl)-                  in sml <= ltime lvl-            then pickNewTarget  -- others will notice soon enough-            else return $! returN "TSmell" tap+            let lvl2 = sdungeon s EM.! lid+            in if not canSmell+                  || let sml = EM.findWithDefault timeZero pos (lsmell lvl2)+                     in sml <= ltime lvl2+               then pickNewTarget  -- others will notice soon enough+               else return $! returN "TSmell" tap           TUnknown ->-            let t = lvl `at` pos+            let lvl2 = sdungeon s EM.! lid+                t = lvl2 `at` pos             in if lidExplored                   || not (isUknownSpace t)                   || condEnoughGear && tileAdj (isStairPos lid) pos@@ -410,13 +410,19 @@                        -- looks silly                then pickNewTarget  -- others will notice soon enough                else return $! returN "TUnknown" tap-          TKnown ->-            if bpos b == pos-               || isStuck-               || alterSkill < fromEnum (lalter PointArray.! pos)-                    -- tile was searched or altered or skill lowered-            then pickNewTarget  -- others unconcerned-            else return $! returN "TKnown" tap+          TKnown ->  -- e.g., staircase or first unknown tile of an area+            let allExplored = ES.size explored == EM.size dungeon+                lvl2 = sdungeon s EM.! lid+            in if bpos b == pos+                  || isStuck+                  || alterSkill < fromEnum (lalter PointArray.! pos)+                       -- tile was searched or altered or skill lowered+                  || Tile.isWalkable coTileSpeedup (lvl2 `at` pos)+                     && not allExplored  -- not patrolling explored dungeon+                       -- tile is no longer unwalkable, so was explored+                       -- so time to recalculate target+               then pickNewTarget  -- others unconcerned+               else return $! returN "TKnown" tap           TAny -> pickNewTarget  -- reset elsewhere or carried over from UI         TVector{} -> if pathLen > 1                      then return $! returN "TVector" tap

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFoldable, DeriveTraversable, TupleSections #-} -- | AI strategies to direct actors not controlled directly by human players.--- No operation in this module involves the 'State' or 'Action' type.+-- No operation in this module involves the 'State' tyep or any of our+-- client/server monads types. module Game.LambdaHack.Client.AI.Strategy   ( Strategy, nullStrategy, liftFrequency   , (.|), reject, (.=>), only, bestVariant, renameStrategy, returN, mapStrategyM@@ -11,6 +12,7 @@ import Game.LambdaHack.Common.Prelude  import Control.Applicative+import Data.Int (Int32)  import Game.LambdaHack.Common.Frequency as Frequency @@ -19,12 +21,16 @@ newtype Strategy a = Strategy { runStrategy :: [Frequency a] }   deriving (Show, Foldable, Traversable) --- | Strategy is a monad.+_maxBound32 :: Integer+_maxBound32 = toInteger (maxBound :: Int32)+ instance Monad Strategy where-  {-# INLINE return #-}-  return x = Strategy $ return $! uniformFreq "Strategy_return" [x]   m >>= f  = normalizeStrategy $ Strategy-    [ toFreq name [ (p * q, b)+    [ toFreq name [+#ifdef WITH_EXPENSIVE_ASSERTIONS+                    assert (toInteger p * toInteger q <= _maxBound32)+#endif+                    (p * q, b)                   | (p, a) <- runFrequency x                   , y <- runStrategy (f a)                   , (q, b) <- runFrequency y@@ -36,7 +42,8 @@   fmap f (Strategy fs) = Strategy (map (fmap f) fs)  instance Applicative Strategy where-  pure  = return+  {-# INLINE pure #-}+  pure x = Strategy $ return $! uniformFreq "Strategy_pure" [x]   (<*>) = ap  instance MonadPlus Strategy where

@@ -1,11 +1,12 @@ {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}--- | Breadth first search algorithms.+-- | Breadth first search algorithm. module Game.LambdaHack.Client.Bfs   ( BfsDistance, MoveLegal(..), minKnownBfs, apartBfs, fillBfs   , AndPath(..), findPathBfs   , accessBfs #ifdef EXPOSE_INTERNAL     -- * Internal operations+  , abortedKnownBfs, abortedUnknownBfs #endif   ) where @@ -13,14 +14,14 @@  import Game.LambdaHack.Common.Prelude -import Control.Monad.ST.Strict-import Data.Binary-import Data.Bits (Bits, complement, (.&.), (.|.))+import           Control.Monad.ST.Strict+import           Data.Binary+import           Data.Bits (Bits, complement, (.&.), (.|.)) import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as VM-import GHC.Generics (Generic)+import           GHC.Generics (Generic) -import Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray  -- | Weighted distance between points along shortest paths.

@@ -1,16 +1,14 @@ {-# LANGUAGE TupleSections #-}--- | Breadth first search and realted algorithms using the client monad.+-- | Breadth first search and related algorithms using the client monad. module Game.LambdaHack.Client.BfsM   ( invalidateBfsAid, invalidateBfsLid, invalidateBfsAll-  , createBfs, condBFS, getCacheBfsAndPath, getCacheBfs-  , getCachePath, createPath-  , unexploredDepth-  , closestUnknown, closestSmell, furthestKnown-  , FleeViaStairsOrEscape(..), embedBenefit, closestTriggers-  , closestItems, closestFoes-  , condEnoughGearM+  , createBfs, getCacheBfsAndPath, getCacheBfs+  , getCachePath, createPath, condBFS+  , furthestKnown, closestUnknown, closestSmell+  , FleeViaStairsOrEscape(..)+  , embedBenefit, closestTriggers, condEnoughGearM, closestItems, closestFoes #ifdef EXPOSE_INTERNAL-  , updatePathFromBfs+  , unexploredDepth, updatePathFromBfs #endif   ) where @@ -20,32 +18,32 @@  import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import Data.Ord-import Data.Word+import           Data.Ord+import           Data.Word -import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.CommonM-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Random+import           Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind (isUknownSpace)+import           Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Content.TileKind (isUknownSpace)  invalidateBfsAid :: MonadClient m => ActorId -> m () invalidateBfsAid aid =@@ -152,9 +150,9 @@   lvl <- getLevel $ blid b   let stopAtUnwalkable tapPath@AndPath{..} =         let (walkable, rest) =-              -- Unknown tiles are not walkable, so path stops before them,-              -- which is good, because by the time actor reaches them,-              -- they are no longer unknown, so target invalidated.+              -- Unknown tiles are not walkable, so path stops at first such.+              -- which is good, because by the time actor reaches the tile,+              -- it is known and target is recalculated with new info.               span (Tile.isWalkable coTileSpeedup . at lvl) pathList         in case rest of           [] -> TgtAndPath{..}@@ -278,7 +276,7 @@ embedBenefit :: MonadClient m              => FleeViaStairsOrEscape -> ActorId              -> [(Point, ItemBag)]-             -> m [(Int, (Point, ItemBag))]+             -> m [(Double, (Point, ItemBag))] embedBenefit fleeVia aid pbags = do   Kind.COps{coitem=Kind.Ops{okind}, coTileSpeedup} <- getsState scops   dungeon <- getsState sdungeon@@ -293,7 +291,7 @@   unexploredTrue <- unexploredDepth True (blid b)   unexploredFalse <- unexploredDepth False (blid b)   condEnoughGear <- condEnoughGearM aid-  discoKind <- getsClient sdiscoKind+  discoKind <- getsState sdiscoKind   discoBenefit <- getsClient sdiscoBenefit   s <- getState   let alterMinSkill p = Tile.alterMinSkill coTileSpeedup $ lvl `at` p@@ -340,7 +338,6 @@             _ -> 0  -- don't ascend prematurely         _ ->           if fleeVia `elem` [ViaNothing, ViaAnything]-           then -- Actor uses the embedded item on himself, hence @effApply@.                -- Let distance be the deciding factor and also prevent                -- overflow on 32-bit machines.@@ -383,9 +380,8 @@     let mix (benefit, ppbag) dist =           let maxd = fromEnum (maxBound :: BfsDistance)                      - fromEnum apartBfs-              -- Bewqre of overflowing 32-bit integers here.-              v = (maxd * 10) `div` (dist + 1)-          in (benefit * v, ppbag)+              v = (fromIntegral maxd * 10) / (fromIntegral dist + 1)+          in (ceiling $ benefit * v, ppbag)     in mapMaybe (\bpp@(_, (p, _)) ->          mix bpp <$> accessBfs bfs p) vicAll 

@@ -0,0 +1,84 @@+{-# LANGUAGE DeriveGeneric #-}+-- | Options that affect the behaviour of the client.+module Game.LambdaHack.Client.ClientOptions+  ( ClientOptions(..), defClientOptions+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Data.Binary+import GHC.Generics (Generic)++-- | Options that affect the behaviour of the client (but not game rules).+data ClientOptions = ClientOptions+  { sgtkFontFamily    :: Maybe Text+      -- ^ Font family to use for the GTK main game window.+  , sdlFontFile       :: Maybe Text+      -- ^ Font file to use for the SDL2 main game window.+  , sdlTtfSizeAdd     :: Maybe Int+      -- ^ Pixels to add to map cells on top of scalable font max glyph height.+  , sdlFonSizeAdd     :: Maybe Int+      -- ^ Pixels to add to map cells on top of .fon font max glyph height.+  , sfontSize         :: Maybe Int+      -- ^ Font size to use for the main game window.+  , scolorIsBold      :: Maybe Bool+      -- ^ Whether to use bold attribute for colorful characters.+  , smaxFps           :: Maybe Int+      -- ^ Maximal frames per second.+      -- This is better low and fixed, to avoid jerkiness and delays+      -- that tell the player there are many intelligent enemies on the level.+      -- That's better than scaling AI sofistication down based+      -- on the FPS setting and machine speed.+  , sdisableAutoYes   :: Bool+      -- ^ Never auto-answer all prompts, even if under AI control.+  , snoAnim           :: Maybe Bool+      -- ^ Don't show any animations.+  , snewGameCli       :: Bool+      -- ^ Start a new game, overwriting the save file.+  , sbenchmark        :: Bool+      -- ^ Don't create directories and files and show time stats.+  , stitle            :: Maybe Text+  , sfontDir          :: Maybe FilePath+  , ssavePrefixCli    :: String+      -- ^ Prefix of the save game file name.+  , sfrontendTeletype :: Bool+      -- ^ Whether to use the stdout/stdin frontend.+  , sfrontendNull     :: Bool+      -- ^ Whether to use null (no input/output) frontend.+  , sfrontendLazy     :: Bool+      -- ^ Whether to use lazy (output not even calculated) frontend.+  , sdbgMsgCli        :: Bool+      -- ^ Show clients' internal debug messages.+  , sstopAfterSeconds :: Maybe Int+  , sstopAfterFrames  :: Maybe Int+  }+  deriving (Show, Eq, Generic)++instance Binary ClientOptions++-- | Default value of client options.+defClientOptions :: ClientOptions+defClientOptions = ClientOptions+  { sgtkFontFamily = Nothing+  , sdlFontFile = Nothing+  , sdlTtfSizeAdd = Nothing+  , sdlFonSizeAdd = Nothing+  , sfontSize = Nothing+  , scolorIsBold = Nothing+  , smaxFps = Nothing+  , sdisableAutoYes = False+  , snoAnim = Nothing+  , snewGameCli = False+  , sbenchmark = False+  , stitle = Nothing+  , sfontDir = Nothing+  , ssavePrefixCli = ""+  , sfrontendTeletype = False+  , sfrontendNull = False+  , sfrontendLazy = False+  , sdbgMsgCli = False+  , sstopAfterSeconds = Nothing+  , sstopAfterFrames = Nothing+  }

@@ -2,9 +2,8 @@ -- | Common client monad operations. module Game.LambdaHack.Client.CommonM   ( getPerFid, aidTgtToPos, makeLine-  , maxActorSkillsClient, currentSkillsClient, fullAssocsClient-  , itemToFullClient, pickWeaponClient, updateSalter, createSalter-  , aspectRecordFromItemClient, aspectRecordFromActorClient, createSactorAspect+  , maxActorSkillsClient, currentSkillsClient, pickWeaponClient+  , updateSalter, createSalter   ) where  import Prelude ()@@ -13,26 +12,26 @@  import qualified Data.EnumMap.Strict as EM -import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.Request+import           Game.LambdaHack.Client.State import qualified Game.LambdaHack.Common.Ability as Ability-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.Random-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Random+import           Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace)+import           Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace)  -- | Get the current perception of a client. getPerFid :: MonadClient m => LevelId -> m Perception@@ -43,7 +42,8 @@   return $! EM.findWithDefault assFail lid fper  -- | Calculate the position of an actor's target.-aidTgtToPos :: MonadClient m => ActorId -> LevelId -> Target -> m (Maybe Point)+aidTgtToPos :: MonadStateRead m+            => ActorId -> LevelId -> Target -> m (Maybe Point) aidTgtToPos aid lidV tgt =   case tgt of     TEnemy a _ -> do@@ -65,7 +65,7 @@ -- an actor or obstacle. Starts searching with the given eps and returns -- the first found eps for which the number reaches the distance between -- actor and target position, or Nothing if none can be found.-makeLine :: MonadClient m => Bool -> Actor -> Point -> Int -> m (Maybe Int)+makeLine :: MonadStateRead m => Bool -> Actor -> Point -> Int -> m (Maybe Int) makeLine onlyFirst body fpos epsOld = do   Kind.COps{coTileSpeedup} <- getsState scops   lvl@Level{lxsize, lysize} <- getLevel (blid body)@@ -73,7 +73,7 @@   let dist = chessDist (bpos body) fpos       calcScore eps = case bla lxsize lysize eps (bpos body) fpos of         Just bl ->-          let blDist = take dist bl+          let blDist = take (dist - 1) bl  -- goal not checked; actor well aware               noActor p = all (bproj . snd) (posA p) || p == fpos               accessibleUnknown tpos =                 let tt = lvl `at` tpos@@ -101,44 +101,23 @@                | otherwise ->                  tryLines (epsOld + 1) (Nothing, minBound)  -- generate best +-- @MonadStateRead@ would be enough, but the logic is sound only on client. maxActorSkillsClient :: MonadClient m => ActorId -> m Ability.Skills maxActorSkillsClient aid = do-  actorAspect <- getsClient sactorAspect-  case EM.lookup aid actorAspect of-    Just aspectRecord -> return $ aSkills aspectRecord  -- keep it lazy-    Nothing -> error $ "" `showFailure` aid+  ar <- getsState $ getActorAspect aid+  return $ aSkills ar  -- keep it lazy  currentSkillsClient :: MonadClient m => ActorId -> m Ability.Skills currentSkillsClient aid = do-  actorAspect <- getsClient sactorAspect-  let ar = fromMaybe (error $ "" `showFailure` aid) (EM.lookup aid actorAspect)   body <- getsState $ getActorBody aid   side <- getsClient sside-  -- Newest Leader in _sleader, not yet in sfactionD.+  -- Newest Leader in sleader, not yet in sfactionD.   mleader <- if side == bfid body-             then getsClient _sleader+             then getsClient sleader              else do                fact <- getsState $ (EM.! bfid body) . sfactionD-               return $! _gleader fact-  getsState $ actorSkills mleader aid ar  -- keep it lazy--fullAssocsClient :: MonadClient m-                 => ActorId -> [CStore] -> m [(ItemId, ItemFull)]-fullAssocsClient aid cstores = do-  cops <- getsState scops-  discoKind <- getsClient sdiscoKind-  discoAspect <- getsClient sdiscoAspect-  getsState $ fullAssocs cops discoKind discoAspect aid cstores--itemToFullClient :: MonadClient m => m (ItemId -> ItemQuant -> ItemFull)-itemToFullClient = do-  cops <- getsState scops-  discoKind <- getsClient sdiscoKind-  discoAspect <- getsClient sdiscoAspect-  s <- getState-  let itemToF iid = itemToFull cops discoKind discoAspect iid-                               (getItemBody iid s)-  return itemToF+               return $! gleader fact+  getsState $ actorSkills mleader aid  -- keep it lazy  -- Client has to choose the weapon based on its partial knowledge, -- because if server chose it, it would leak item discovery information.@@ -146,15 +125,13 @@                  => ActorId -> ActorId                  -> m (Maybe (RequestTimed 'Ability.AbMelee)) pickWeaponClient source target = do-  eqpAssocs <- fullAssocsClient source [CEqp]-  bodyAssocs <- fullAssocsClient source [COrgan]+  eqpAssocs <- getsState $ fullAssocs source [CEqp]+  bodyAssocs <- getsState $ fullAssocs source [COrgan]   actorSk <- currentSkillsClient source-  actorAspect <- getsClient sactorAspect   let allAssocsRaw = eqpAssocs ++ bodyAssocs       allAssocs = filter (isMelee . itemBase . snd) allAssocsRaw   discoBenefit <- getsClient sdiscoBenefit-  strongest <- pickWeaponM (Just discoBenefit)-                           allAssocs actorSk actorAspect source+  strongest <- pickWeaponM (Just discoBenefit) allAssocs actorSk source   case strongest of     [] -> return Nothing     iis@((maxS, _) : _) -> do@@ -177,45 +154,3 @@       f Level{ltile} =         PointArray.mapA (toEnum . Tile.alterMinWalk coTileSpeedup) ltile   in EM.map f $ sdungeon s--aspectRecordFromItem :: DiscoveryKind -> DiscoveryAspect -> ItemId -> Item-                     -> AspectRecord-aspectRecordFromItem disco discoAspect iid itemBase =-  case EM.lookup iid discoAspect of-    Just ar -> ar-    Nothing -> case EM.lookup (jkindIx itemBase) disco of-        Just KindMean{kmMean} -> kmMean-        Nothing -> emptyAspectRecord--aspectRecordFromItemClient :: MonadClient m => ItemId -> Item -> m AspectRecord-aspectRecordFromItemClient iid itemBase = do-  disco <- getsClient sdiscoKind-  discoAspect <- getsClient sdiscoAspect-  return $! aspectRecordFromItem disco discoAspect iid itemBase--aspectRecordFromActorState :: DiscoveryKind -> DiscoveryAspect -> Actor -> State-                           -> AspectRecord-aspectRecordFromActorState disco discoAspect b s =-  let processIid (iid, (k, _)) =-        let itemBase = getItemBody iid s-            ar = aspectRecordFromItem disco discoAspect iid itemBase-        in (ar, k)-      processBag ass = sumAspectRecord $ map processIid ass-  in processBag $ EM.assocs (borgan b) ++ EM.assocs (beqp b)--aspectRecordFromActorClient :: MonadClient m-                            => Actor -> [(ItemId, Item)] -> m AspectRecord-aspectRecordFromActorClient b ais = do-  disco <- getsClient sdiscoKind-  discoAspect <- getsClient sdiscoAspect-  s <- getState-  let f (iid, itemBase) = EM.insert iid itemBase-      sAis = updateItemD (\itemD -> foldr f itemD ais) s-  return $! aspectRecordFromActorState disco discoAspect b sAis--createSactorAspect :: MonadClient m => State -> m ActorAspect-createSactorAspect s = do-  disco <- getsClient sdiscoKind-  discoAspect <- getsClient sdiscoAspect-  let f b = aspectRecordFromActorState disco discoAspect b s-  return $! EM.map f $ sactorD s

@@ -1,6 +1,14 @@ -- | Handle atomic commands received by the client. module Game.LambdaHack.Client.HandleAtomicM-  ( cmdAtomicSemCli, cmdAtomicFilterCli+  ( MonadClientSetup(..)+  , cmdAtomicSemCli+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , wipeBfsIfItemAffectsSkills, tileChangeAffectsBfs, createActor, destroyActor+  , addItemToDiscoBenefit, perception+  , discoverKind, coverKind, discoverSeed, coverSeed+  , killExit+#endif   ) where  import Prelude ()@@ -8,268 +16,75 @@ import Game.LambdaHack.Common.Prelude  import qualified Data.EnumMap.Strict as EM-import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M-import Data.Ord-import qualified NLP.Miniutter.English as MU+import           Data.Ord -import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.BfsM-import Game.LambdaHack.Client.CommonM-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.Preferences-import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item+import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.BfsM+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.Preferences+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Content.ItemKind (ItemKind)+import           Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind (ModeKind)-import Game.LambdaHack.Content.TileKind (TileKind)-import qualified Game.LambdaHack.Content.TileKind as TK---- * RespUpdAtomicAI+import           Game.LambdaHack.Content.ModeKind (ModeKind)+import           Game.LambdaHack.Content.TileKind (TileKind) --- | Clients keep a subset of atomic commands sent by the server--- and add some of their own. The result of this function is the list--- of commands kept for each command received.-cmdAtomicFilterCli :: MonadClient m => UpdAtomic -> m [UpdAtomic]-{-# INLINE cmdAtomicFilterCli #-}-cmdAtomicFilterCli cmd = case cmd of-  UpdSpotActor aid _ _ -> do-    -- Needed, e.g., when we teleport and so see our actor at the new-    -- location, but also the location is part of new perception,-    -- so @UpdSpotActor@ is sent.-    alreadyAdded <- getsState $ EM.member aid . sactorD-    return $! if alreadyAdded then [] else [cmd]-  UpdAlterTile lid p fromTile toTile -> do-    Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops-    lvl <- getLevel lid-    let t = lvl `at` p-    if t == fromTile-      then return [cmd]-      else do-        -- From @UpdAlterTile@ we know @t == freshClientTile@,-        -- which is uncanny, so we produce a message.-        -- It happens when a client thinks the tile is @t@,-        -- but it's @fromTile@, and @UpdAlterTile@ changes it-        -- to @toTile@. See @updAlterTile@.-        let subject = ""  -- a hack, we we don't handle adverbs well-            verb = "turn into"-            msg = makeSentence [ "the", MU.Text $ TK.tname $ okind t-                               , "at position", MU.Text $ tshow p-                               , "suddenly"  -- adverb-                               , MU.SubjectVerbSg subject verb-                               , MU.AW $ MU.Text $ TK.tname $ okind toTile ]-        return [ cmd  -- reveal the tile-               , UpdMsgAll msg  -- show the message-               ]-  UpdSearchTile aid p toTile -> do-    Kind.COps{cotile} <- getsState scops-    b <- getsState $ getActorBody aid-    lvl <- getLevel $ blid b-    let t = lvl `at` p-        fromTile = Tile.hideAs cotile toTile-    return $!-      if t == fromTile-      then -- Fully ignorant. (No intermediate knowledge possible.)-           [ cmd  -- show the message-           , UpdAlterTile (blid b) p fromTile toTile  -- reveal tile-           ]-      else assert (t == toTile `blame` "LoseTile fails to reset memory"-                               `swith` (aid, p, fromTile, toTile, b, t, cmd))-                  [cmd]  -- Already knows the tile fully, only confirm.-  UpdHideTile{} -> return []  -- will be fleshed out when Undo completed-  UpdSpotTile lid ts -> do-    Kind.COps{cotile} <- getsState scops-    lvl <- getLevel lid-    -- We ignore the server resending us hidden versions of the tiles-    -- (and resending us the same data we already got).-    -- If the tiles are changed to other variants of the hidden tile,-    -- we can still verify by searching.-    let notKnown (p, t) = let tClient = lvl `at` p-                          in Tile.hideAs cotile tClient /= t-        newTs = filter notKnown ts-    return $! if null newTs then [] else [UpdSpotTile lid newTs]-  UpdDiscover c iid _ seed -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        discoKind <- getsClient sdiscoKind-        if jkindIx item `EM.member` discoKind-          then do-            discoAspect <- getsClient sdiscoAspect-            if iid `EM.member` discoAspect-              then return []-              else return [UpdDiscoverSeed c iid seed]-          else return [cmd]-  UpdCover c iid ik _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        discoKind <- getsClient sdiscoKind-        if jkindIx item `EM.notMember` discoKind-          then return []-          else do-            discoAspect <- getsClient sdiscoAspect-            if iid `EM.notMember` discoAspect-              then return [cmd]-              else return [UpdCoverKind c iid ik]-  UpdDiscoverKind _ iid _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        discoKind <- getsClient sdiscoKind-        if jkindIx item `EM.notMember` discoKind-        then return []-        else return [cmd]-  UpdCoverKind _ iid _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        discoKind <- getsClient sdiscoKind-        if jkindIx item `EM.notMember` discoKind-        then return []-        else return [cmd]-  UpdDiscoverSeed _ iid _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        discoKind <- getsClient sdiscoKind-        if jkindIx item `EM.notMember` discoKind-        then return []-        else do-          discoAspect <- getsClient sdiscoAspect-          if iid `EM.member` discoAspect-            then return []-            else return [cmd]-  UpdCoverSeed _ iid _ -> do-    itemD <- getsState sitemD-    case EM.lookup iid itemD of-      Nothing -> return []-      Just item -> do-        discoKind <- getsClient sdiscoKind-        if jkindIx item `EM.notMember` discoKind-        then return []-        else do-          discoAspect <- getsClient sdiscoAspect-          if iid `EM.notMember` discoAspect-            then return []-            else return [cmd]-  UpdPerception lid outPer inPer -> do-    -- Here we cheat by setting a new perception outright instead of-    -- in @cmdAtomicSemCli@, to avoid computing perception twice.-    perOld <- getPerFid lid-    perception lid outPer inPer-    perNew <- getPerFid lid-    carriedAssocs <- getsState $ flip getCarriedAssocs-    fid <- getsClient sside-    s <- getState-    -- Wipe out actors that just became invisible due to changed FOV.-    let seenNew = seenAtomicCli False fid perNew-        seenOld = seenAtomicCli False fid perOld-        outFov = totalVisible outPer-        outPrio = concatMap (\p -> posToAssocs p lid s) $ ES.elems outFov-        fActor (aid, b) =-          let ps = posProjBody b-              -- Verify that we forget only previously seen actors.-              !_A = assert (seenOld ps) ()-          in -- We forget only currently invisible actors.-             if seenNew ps-             then Nothing-             else Just $ UpdLoseActor aid b $ carriedAssocs b-        outActor = mapMaybe fActor outPrio-    -- Wipe out remembered items on tiles that now came into view.-    lvl <- getLevel lid-    let inFov = ES.elems $ totalVisible inPer-        pMaybe p = maybe Nothing (\x -> Just (p, x))-        inContainer fc itemFloor =-          let inItem = mapMaybe (\p -> pMaybe p $ EM.lookup p itemFloor) inFov-              fItem p (iid, kit) =-                UpdLoseItem True iid (getItemBody iid s) kit (fc lid p)-              fBag (p, bag) = map (fItem p) $ EM.assocs bag-          in concatMap fBag inItem-        inFloor = inContainer CFloor (lfloor lvl)-        inEmbed = inContainer CEmbed (lembed lvl)-    -- Remembered map tiles not wiped out, due to optimization in @updSpotTile@.-    -- Wipe out remembered smell on tiles that now came into smell Fov.-    let inSmellFov = totalSmelled inPer-        inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl))-                        (ES.elems inSmellFov)-        inSmell = if null inSm then [] else [UpdLoseSmell lid inSm]-    let inTileSmell = inFloor ++ inEmbed ++ inSmell-    psItemSmell <- mapM posUpdAtomic inTileSmell-    -- Verify that we forget only previously invisible items and smell.-    let !_A = assert (allB (not . seenOld) psItemSmell) ()-    -- Verify that we forget only currently seen items and smell.-    let !_A = assert (allB seenNew psItemSmell) ()-    return $! cmd : outActor ++ inTileSmell-  _ -> return [cmd]+-- | Client monad for saving and restarting games.+class MonadClient m => MonadClientSetup m where+  saveClient    :: m ()+  restartClient :: m () --- | Effect of atomic actions on client state is calculated--- with the global state from before the command is executed.-cmdAtomicSemCli :: MonadClientSetup m => UpdAtomic -> m ()+-- | Effect of atomic actions on client state. It is calculated+-- with the global state from after the command is executed+-- (except where the supplied @oldState@ is used).+cmdAtomicSemCli :: MonadClientSetup m => State -> UpdAtomic -> m () {-# INLINE cmdAtomicSemCli #-}-cmdAtomicSemCli cmd = case cmd of+cmdAtomicSemCli oldState cmd = case cmd of   UpdCreateActor aid b ais -> createActor aid b ais   UpdDestroyActor aid b _ -> destroyActor aid b True-  UpdCreateItem iid itemBase (k, _) (CActor aid store) -> do+  UpdCreateItem iid itemBase _ (CActor aid store) -> do     wipeBfsIfItemAffectsSkills [store] aid-    when (store `elem` [CEqp, COrgan]) $ addItemToActor iid itemBase k aid     addItemToDiscoBenefit iid itemBase   UpdCreateItem iid itemBase _ _ -> addItemToDiscoBenefit iid itemBase-  UpdDestroyItem iid itemBase (k, _) (CActor aid store) -> do+  UpdDestroyItem _ _ _ (CActor aid store) ->     wipeBfsIfItemAffectsSkills [store] aid-    when (store `elem` [CEqp, COrgan]) $ addItemToActor iid itemBase (-k) aid   UpdSpotActor aid b ais -> createActor aid b ais   UpdLoseActor aid b _ -> destroyActor aid b False-  UpdSpotItem _ iid itemBase (k, _) (CActor aid store) -> do+  UpdSpotItem _ iid itemBase _ (CActor aid store) -> do     wipeBfsIfItemAffectsSkills [store] aid-    when (store `elem` [CEqp, COrgan]) $ addItemToActor iid itemBase k aid     addItemToDiscoBenefit iid itemBase   UpdSpotItem _ iid itemBase _ _ -> addItemToDiscoBenefit iid itemBase-  UpdLoseItem _ iid itemBase (k, _) (CActor aid store) -> do+  UpdLoseItem _ _ _ _ (CActor aid store) ->     wipeBfsIfItemAffectsSkills [store] aid-    when (store `elem` [CEqp, COrgan]) $ addItemToActor iid itemBase (-k) aid+  UpdSpotItemBag (CActor aid store) _bag ais -> do+    wipeBfsIfItemAffectsSkills [store] aid+    mapM_ (\(iid, item) -> addItemToDiscoBenefit iid item) ais+  UpdSpotItemBag _ _ ais ->+    mapM_ (\(iid, item) -> addItemToDiscoBenefit iid item) ais+  UpdLoseItemBag (CActor aid store) _bag _ais ->+    wipeBfsIfItemAffectsSkills [store] aid   UpdMoveActor aid _ _ -> invalidateBfsAid aid   UpdDisplaceActor source target -> do     invalidateBfsAid source     invalidateBfsAid target-  UpdMoveItem iid k aid s1 s2 -> do-    wipeBfsIfItemAffectsSkills [s1, s2] aid-    case s1 of-      CEqp -> case s2 of-        COrgan -> return ()-        _ -> do-          itemBase <- getsState $ getItemBody iid-          addItemToActor iid itemBase (-k) aid-      COrgan -> case s2 of-        CEqp -> return ()-        _ -> do-          itemBase <- getsState $ getItemBody iid-          addItemToActor iid itemBase (-k) aid-      _ ->-        when (s2 `elem` [CEqp, COrgan]) $ do-          itemBase <- getsState $ getItemBody iid-          addItemToActor iid itemBase k aid+  UpdMoveItem _ _ aid s1 s2 -> wipeBfsIfItemAffectsSkills [s1, s2] aid   UpdLeadFaction fid source target -> do     side <- getsClient sside     when (side == fid) $ do-      mleader <- getsClient _sleader+      mleader <- getsClient sleader       let !_A = assert (mleader == source                           -- somebody changed the leader for us                         || mleader == target@@ -282,7 +97,7 @@     invalidateBfsAll   UpdTacticFaction{} -> do     -- Clear all targets except the leader's.-    mleader <- getsClient _sleader+    mleader <- getsClient sleader     mtgt <- case mleader of       Nothing -> return Nothing       Just leader -> getsClient $ EM.lookup leader . stargetD@@ -290,19 +105,35 @@       cli { stargetD = case (mtgt, mleader) of               (Just tgt, Just leader) -> EM.singleton leader tgt               _ -> EM.empty }-  UpdAlterTile lid pos _fromTile toTile -> do-    updateSalter lid [(pos, toTile)]+  UpdAlterTile lid p fromTile toTile -> do+    updateSalter lid [(p, toTile)]     cops <- getsState scops-    lvl <- getLevel lid-    let assumedTile = lvl `at` pos-    when (tileChangeAffectsBfs cops assumedTile toTile) $+    let lvl = (EM.! lid) . sdungeon $ oldState+        t = lvl `at` p+    let !_A = assert (t == fromTile) ()+    when (tileChangeAffectsBfs cops fromTile toTile) $       invalidateBfsLid lid+  UpdSearchTile aid p toTile -> do+    Kind.COps{cotile} <- getsState scops+    b <- getsState $ getActorBody aid+    let lid = blid b+    updateSalter lid [(p, toTile)]+    cops <- getsState scops+    let lvl = (EM.! lid) . sdungeon $ oldState+        t = lvl `at` p+    let !_A = assert (Just t == Tile.hideAs cotile toTile) ()+    -- The following check is needed even if we verity in content+    -- that searching doesn't change clarity and light of tiles,+    -- because it modifies skill needed to alter the tile and even+    -- walkability and changeability.+    when (tileChangeAffectsBfs cops t toTile) $+      invalidateBfsLid lid   UpdSpotTile lid ts -> do     updateSalter lid ts     cops <- getsState scops-    lvl <- getLevel lid-    let affects (pos, toTile) =-          let fromTile = lvl `at` pos+    let lvl = (EM.! lid) . sdungeon $ oldState+        affects (p, toTile) =+          let fromTile = lvl `at` p           in tileChangeAffectsBfs cops fromTile toTile         bs = map affects ts     when (or bs) $ invalidateBfsLid lid@@ -315,17 +146,19 @@       let g !em !lid = EM.adjust (const Nothing) lid em       in cli {scondInMelee = foldl' g (scondInMelee cli) arenas}   UpdDiscover c iid ik seed -> do-    discoverKind c iid ik+    item <- getsState $ getItemBody iid+    discoverKind c (jkindIx item) ik     discoverSeed c iid seed   UpdCover c iid ik seed -> do     coverSeed c iid seed-    coverKind c iid ik-  UpdDiscoverKind c iid ik -> discoverKind c iid ik-  UpdCoverKind c iid ik -> coverKind c iid ik+    item <- getsState $ getItemBody iid+    coverKind c (jkindIx item) ik+  UpdDiscoverKind c ix ik -> discoverKind c ix ik+  UpdCoverKind c ix ik -> coverKind c ix ik   UpdDiscoverSeed c iid seed -> discoverSeed c iid seed   UpdCoverSeed c iid seed -> coverSeed c iid seed-  -- UpdPerception lid outPer inPer -> perception lid outPer inPer-  UpdRestart side sdiscoKind sfper s scurChal sdebugCli -> do+  UpdPerception lid outPer inPer -> perception lid outPer inPer+  UpdRestart side sfper s scurChal soptions -> do     Kind.COps{comode=Kind.Ops{ofoldlGroup'}} <- getsState scops     snxtChal <- getsClient snxtChal     svictories <- getsClient svictories@@ -337,19 +170,16 @@           Just cm -> fromMaybe 0 (M.lookup snxtChal cm)         (snxtScenario, _) = minimumBy (comparing g) modes         cli = emptyStateClient side-    putClient cli { sdiscoKind-                  , sfper+    putClient cli { sfper                   -- , sundo = [UpdAtomic cmd]                   , scurChal                   , snxtChal                   , snxtScenario                   , scondInMelee = EM.map (const Nothing) (sdungeon s)                   , svictories-                  , sdebugCli }-    modifyClient $ \cli1 -> cli1 {salter = createSalter s}-    -- Currently always void, because no actors yet:-    sactorAspect <- createSactorAspect s-    modifyClient $ \cli1 -> cli1 {sactorAspect}+                  , soptions }+    salter <- getsState createSalter+    modifyClient $ \cli1 -> cli1 {salter}     restartClient   UpdResume _fid sfperNew -> do #ifdef WITH_EXPENSIVE_ASSERTIONS@@ -357,10 +187,8 @@     let !_A = assert (sfperNew == sfperOld `blame` (sfperNew, sfperOld)) () #endif     modifyClient $ \cli -> cli {sfper=sfperNew}-    s <- getState-    modifyClient $ \cli -> cli {salter = createSalter s}-    sactorAspect <- createSactorAspect s-    modifyClient $ \cli -> cli {sactorAspect}+    salter <- getsState createSalter+    modifyClient $ \cli -> cli {salter}   UpdKillExit _fid -> killExit   UpdWriteSave -> saveClient   _ -> return ()@@ -386,9 +214,6 @@           TgtAndPath (TEnemy a newPermit) NoPath         _ -> tap   modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}-  aspectRecord <- aspectRecordFromActorClient b ais-  let f = EM.insert aid aspectRecord-  modifyClient $ \cli -> cli {sactorAspect = f $ sactorAspect cli}   mapM_ (uncurry addItemToDiscoBenefit) ais  destroyActor :: MonadClient m => ActorId -> Actor -> Bool -> m ()@@ -411,30 +236,23 @@               _ -> tapPath  -- foe slow enough, so old path good         in TgtAndPath (affect tapTgt) newMPath   modifyClient $ \cli -> cli {stargetD = EM.map affect3 (stargetD cli)}-  let f = EM.delete aid-  modifyClient $ \cli -> cli {sactorAspect = f $ sactorAspect cli} -addItemToActor :: MonadClient m => ItemId -> Item -> Int -> ActorId -> m ()-addItemToActor iid itemBase k aid = do-  arItem <- aspectRecordFromItemClient iid itemBase-  let g arActor = sumAspectRecord [(arActor, 1), (arItem, k)]-      f = EM.adjust g aid-  modifyClient $ \cli -> cli {sactorAspect = f $ sactorAspect cli}- addItemToDiscoBenefit :: MonadClient m => ItemId -> Item -> m () addItemToDiscoBenefit iid item = do   cops@Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops   discoBenefit <- getsClient sdiscoBenefit   case EM.lookup iid discoBenefit of-    Just{} -> return ()  -- already there+    Just{} -> return ()  -- already there, possibly with real aspects, too     Nothing -> do-      discoKind <- getsClient sdiscoKind+      discoKind <- getsState sdiscoKind       case EM.lookup (jkindIx item) discoKind of         Nothing -> return ()         Just KindMean{..} -> do  -- possible, if the kind sent in @UpdRestart@           side <- getsClient sside           fact <- getsState $ (EM.! side) . sfactionD           let effects = IK.ieffects $ okind kmKind+              -- Mean aspects are used, because the item can't yet have+              -- know real aspects, because it didn't even have kind before.               benefit = totalUsefulness cops fact effects kmMean item           modifyClient $ \cli ->             cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)}@@ -464,90 +282,52 @@         f = EM.alter adj lid     modifyClient $ \cli -> cli {sfper = f (sfper cli)} -discoverKind :: MonadClient m => Container -> ItemId -> Kind.Id ItemKind -> m ()-discoverKind c iid kmKind = do+discoverKind :: MonadClient m+             => Container -> ItemKindIx -> Kind.Id ItemKind -> m ()+discoverKind _c ix ik = do   cops@Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops   -- Wipe out BFS, because the player could potentially learn that his items   -- affect his actors' skills relevant to BFS.   invalidateBfsAll   side <- getsClient sside   fact <- getsState $ (EM.! side) . sfactionD-  item <- getsState $ getItemBody iid-  let kind = okind kmKind-      kmMean = meanAspect kind-      benefit = totalUsefulness cops fact (IK.ieffects kind) kmMean item-      f Nothing = Just KindMean{..}-      f Just{} = error $ "already discovered"-                         `showFailure` (c, iid, kmKind)-  -- This adds to @sdiscoBenefit@ only @iid@ and not any other items-  -- that share the same @jkindIx@, so this is broken if such items-  -- are not fully IDed from the start.-  modifyClient $ \cli ->-    cli { sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)-        , sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli) }-  -- Each actor's equipment and organs would need to be inspected,-  -- the iid looked up, e.g., if it wasn't in old discoKind, but is in new,-  -- and then aspect record updated, so it's simpler and not much more-  -- expensive to generate new sactorAspect. Optimize only after profiling.-  s <- getState-  sactorAspect <- createSactorAspect s-  modifyClient $ \cli -> cli {sactorAspect}+  discoKind <- getsState sdiscoKind+  itemD <- getsState sitemD+  let effs = IK.ieffects $ okind ik+      KindMean{kmMean} = fromMaybe (error "item kind not found")+                                   (EM.lookup ix discoKind)+      benefit iid =+        let item = itemD EM.! iid+        in totalUsefulness cops fact effs kmMean item+  itemIxMap <- getsState $ (EM.! ix) . sitemIxMap+  forM_ itemIxMap $ \iid -> modifyClient $ \cli ->+    cli {sdiscoBenefit = EM.insert iid (benefit iid) (sdiscoBenefit cli)} -coverKind :: MonadClient m => Container -> ItemId -> Kind.Id ItemKind -> m ()-coverKind c iid ik = do-  item <- getsState $ getItemBody iid-  let f Nothing = error $ "already covered" `showFailure` (c, iid, ik)-      f (Just KindMean{kmKind}) =-        assert (ik == kmKind `blame` "unexpected covered item kind"-                             `swith` (ik, kmKind)) Nothing-  -- For now, undoing @sdiscoBenefit@ is too much work.-  modifyClient $ \cli ->-    cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)}-  s <- getState-  sactorAspect <- createSactorAspect s-  modifyClient $ \cli -> cli {sactorAspect}+coverKind :: Container -> ItemKindIx -> Kind.Id ItemKind -> m ()+coverKind _c _iid _ik = undefined  discoverSeed :: MonadClient m => Container -> ItemId -> ItemSeed -> m ()-discoverSeed c iid seed = do+discoverSeed _c iid seed = do   cops@Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops   -- Wipe out BFS, because the player could potentially learn that his items   -- affect his actors' skills relevant to BFS.   invalidateBfsAll   side <- getsClient sside   fact <- getsState $ (EM.! side) . sfactionD-  discoKind <- getsClient sdiscoKind+  discoKind <- getsState sdiscoKind   item <- getsState $ getItemBody iid   totalDepth <- getsState stotalDepth-  case EM.lookup (jkindIx item) discoKind of-    Nothing -> error $ "kind not known"-                       `showFailure` (c, iid, seed)-    Just KindMean{kmKind} -> do-      Level{ldepth} <- getLevel $ jlid item-      let kind = okind kmKind-          aspects = seedToAspect seed kind ldepth totalDepth-          benefit = totalUsefulness cops fact (IK.ieffects kind) aspects item-          f Nothing = Just aspects-          f Just{} = error $ "already discovered"-                             `showFailure` (c, iid, seed)-  -- This adds to @sdiscoBenefit@ only @iid@ and not any other items-  -- that share the same @jkindIx@, so this is broken if such items-  -- are not fully IDed from the start.-      modifyClient $ \cli ->-        cli { sdiscoAspect = EM.alter f iid (sdiscoAspect cli)-            , sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli) }-  s <- getState-  sactorAspect <- createSactorAspect s-  modifyClient $ \cli -> cli {sactorAspect}+  Level{ldepth} <- getLevel $ jlid item+  let KindMean{..} = fromMaybe (error "item kind not found")+                               (EM.lookup (jkindIx item) discoKind)+      kind = okind kmKind+      aspects = seedToAspect seed kind ldepth totalDepth+      benefit = totalUsefulness cops fact (IK.ieffects kind) aspects item+  modifyClient $ \cli ->+    cli {sdiscoBenefit = EM.insert iid benefit (sdiscoBenefit cli)} -coverSeed :: MonadClient m => Container -> ItemId -> ItemSeed -> m ()-coverSeed c iid seed = do-  let f Nothing = error $ "already covered" `showFailure` (c, iid, seed)-      f Just{} = Nothing  -- checking that old and new agree is too much work-  -- For now, undoing @sdiscoBenefit@ is too much work.-  modifyClient $ \cli -> cli {sdiscoAspect = EM.alter f iid (sdiscoAspect cli)}-  s <- getState-  sactorAspect <- createSactorAspect s-  modifyClient $ \cli -> cli {sactorAspect}+coverSeed :: Container -> ItemId -> ItemSeed -> m ()+coverSeed _c _iid _seed = undefined  killExit :: MonadClient m => m () killExit = do@@ -556,12 +336,11 @@   modifyClient $ \cli -> cli {squit = True}   -- Verify that the not saved caches are equal to future reconstructed.   -- Otherwise, save/restore would change game state.-  sactorAspect <- getsClient sactorAspect+  sactorAspect2 <- getsState sactorAspect   salter <- getsClient salter   sbfsD <- getsClient sbfsD-  s <- getState-  let alter = createSalter s-  actorAspect <- createSactorAspect s+  alter <- getsState createSalter+  actorAspect <- getsState actorAspectInDungeon   let f aid = do         (canMove, alterSkill) <- condBFS aid         bfsArr <- createBfs canMove alterSkill aid@@ -579,9 +358,9 @@   let !_A1 = assert (salter == alter                      `blame` "wrong accumulated salter on side"                      `swith` (side, salter, alter)) ()-      !_A2 = assert (sactorAspect == actorAspect+      !_A2 = assert (sactorAspect2 == actorAspect                      `blame` "wrong accumulated sactorAspect on side"-                     `swith` (side, sactorAspect, actorAspect)) ()+                     `swith` (side, sactorAspect2, actorAspect)) ()       !_A3 = assert (sbfsD `subBfs` bfsD                      `blame` "wrong accumulated sbfsD on side"                      `swith` (side, sbfsD, bfsD)) ()

@@ -1,7 +1,8 @@ {-# LANGUAGE FlexibleContexts #-}--- | Semantics of client commands.+-- | Semantics of responses sent by the server to clients. module Game.LambdaHack.Client.HandleResponseM-  ( MonadClientReadResponse(..), MonadClientWriteRequest(..)+  ( MonadClientWriteRequest(..)+  , MonadClientAtomic(..)   , handleResponse   ) where @@ -9,37 +10,55 @@  import Game.LambdaHack.Common.Prelude -import Game.LambdaHack.Atomic+import Game.LambdaHack.Atomic (UpdAtomic) import Game.LambdaHack.Client.AI import Game.LambdaHack.Client.HandleAtomicM import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.Request+import Game.LambdaHack.Client.Response import Game.LambdaHack.Client.UI-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response--class MonadClient m => MonadClientReadResponse m where-  receiveResponse :: m Response+import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.State +-- | Client monad in which one can send requests to the client. class MonadClient m => MonadClientWriteRequest m where   sendRequestAI :: RequestAI -> m ()   sendRequestUI :: RequestUI -> m ()   clientHasUI   :: m Bool +-- | Monad for executing atomic game state transformations on a client.+class MonadClient m => MonadClientAtomic m where+  -- | Execute an atomic update that changes the client's 'State'.+  execUpdAtomic :: UpdAtomic -> m ()+  -- | Put state that is intended to be the result of performing+  -- an atomic update by the server on its copy of the client's 'State'.+  execPutState :: State -> m ()++-- | Handle server responses.+--+-- Note that for clients communicating with the server over the net,+-- @RespUpdAtomicNoState@ should be used, because executing a single command+-- is cheaper than sending the whole state over the net.+-- However, for the standalone exe mode, with clients in the same process+-- as the server, a pointer to the state set with @execPutState@ is cheaper. handleResponse :: ( MonadClientSetup m                   , MonadClientUI m-                  , MonadAtomic m+                  , MonadClientAtomic m                   , MonadClientWriteRequest m )                => Response -> m () handleResponse cmd = case cmd of-  RespUpdAtomic cmdA -> do+  RespUpdAtomic newState cmdA -> do+    oldState <- getState+    execPutState newState+    cmdAtomicSemCli oldState cmdA     hasUI <- clientHasUI-    cmds <- cmdAtomicFilterCli cmdA-    let handle !c = do-          cli <- getClient-          cmdAtomicSemCli c-          execUpdAtomic c-          when hasUI $ displayRespUpdAtomicUI False cli c-    mapM_ handle cmds+    when hasUI $ displayRespUpdAtomicUI False cmdA+  RespUpdAtomicNoState cmdA -> do+    oldState <- getState+    execUpdAtomic cmdA+    cmdAtomicSemCli oldState cmdA+    hasUI <- clientHasUI+    when hasUI $ displayRespUpdAtomicUI False cmdA   RespQueryAI aid -> do     cmdC <- queryAI aid     sendRequestAI cmdC

@@ -2,7 +2,12 @@ -- | The main loop of the client, processing human and computer player -- moves turn by turn. module Game.LambdaHack.Client.LoopM-  ( loopCli+  ( MonadClientReadResponse(..)+  , loopCli+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , initAI, initUI+#endif   ) where  import Prelude ()@@ -10,63 +15,74 @@ import Game.LambdaHack.Common.Prelude  import Game.LambdaHack.Atomic+import Game.LambdaHack.Client.ClientOptions+import Game.LambdaHack.Client.HandleAtomicM import Game.LambdaHack.Client.HandleResponseM import Game.LambdaHack.Client.MonadClient+import Game.LambdaHack.Client.Response import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI-import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Response import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Vector -initAI :: MonadClient m => DebugModeCli -> m ()-initAI sdebugCli = do-  modifyClient $ \cli -> cli {sdebugCli}+-- | Client monad in which one can receive responses from the server.+class MonadClient m => MonadClientReadResponse m where+  receiveResponse :: m Response++initAI :: MonadClient m => m ()+initAI = do   side <- getsClient sside   debugPossiblyPrint $ "AI client" <+> tshow side <+> "initializing." -initUI :: MonadClientUI m => KeyKind -> Config -> DebugModeCli -> m ()-initUI copsClient sconfig sdebugCli = do-  modifyClient $ \cli -> cli {sdebugCli}+initUI :: MonadClientUI m => KeyKind -> UIOptions -> m ()+initUI copsClient sUIOptions = do   side <- getsClient sside+  soptions <- getsClient soptions   debugPossiblyPrint $ "UI client" <+> tshow side <+> "initializing."   -- Start the frontend.-  schanF <- chanFrontend sdebugCli-  let !sbinding = stdBinding copsClient sconfig  -- evaluate to check for errors-      sess = emptySessionUI sconfig-  putSession sess { schanF-                  , sbinding-                  , sxhair = TVector $ Vector 1 1 }-                      -- a step south-east, less alarming+  schanF <- chanFrontend soptions+  let !sbinding = stdBinding copsClient sUIOptions+        -- evaluate to check for errors+  modifySession $ \sess ->+    sess { schanF+         , sbinding+         , sxhair = TVector $ Vector 1 1 }+             -- a step south-east, less alarming --- | The main game loop for an AI or UI client.+-- | The main game loop for an AI or UI client. It receives responses from+-- the server, changes internal client state accordingly, analyzes+-- ensuing human or AI commands and sends resulting requests to the server.+-- Depending on whether it's an AI or UI client, it sends AI or human player+-- requests.+--+-- The loop is started in client state that is empty except for+-- the @sside@ and @seps@ fields, see 'emptyStateClient'. loopCli :: ( MonadClientSetup m            , MonadClientUI m-           , MonadAtomic m+           , MonadClientAtomic m            , MonadClientReadResponse m            , MonadClientWriteRequest m )-        => KeyKind -> Config -> DebugModeCli -> m ()-loopCli copsClient sconfig sdebugCli = do+        => KeyKind -> UIOptions -> ClientOptions -> m ()+loopCli copsClient sUIOptions soptions = do+  modifyClient $ \cli -> cli {soptions}   hasUI <- clientHasUI-  if not hasUI then initAI sdebugCli else initUI copsClient sconfig sdebugCli+  if not hasUI then initAI else initUI copsClient sUIOptions   -- Warning: state and client state are invalid here, e.g., sdungeon   -- and sper are empty.   cops <- getsState scops   restoredG <- tryRestore   restored <- case restoredG of-    Just (s, cli, msess) | not $ snewGameCli sdebugCli -> do+    Just (cli, msess) | not $ snewGameCli soptions -> do       -- Restore game.-      let sCops = updateCOps (const cops) s-      handleResponse $ RespUpdAtomic $ UpdResumeServer sCops       schanF <- getsSession schanF       sbinding <- getsSession sbinding-      maybe (return ()) (\sess ->-        putSession sess {schanF, sbinding, sconfig}) msess-      putClient cli {sdebugCli}+      maybe (return ()) (\sess -> modifySession $ \_ ->+        sess {schanF, sbinding, sUIOptions}) msess+      putClient cli {soptions}       return True-    Just (_, _, msessR) -> do+    Just (_, msessR) -> do       -- Preserve previous history, if any (--newGame).       maybe (return ()) (\sessR -> modifySession $ \sess ->         sess {shistory = shistory sessR}) msessR@@ -75,13 +91,22 @@   side <- getsClient sside   cmd1 <- receiveResponse   case (restored, cmd1) of-    (True, RespUpdAtomic UpdResume{}) -> return ()-    (True, RespUpdAtomic UpdRestart{}) ->+    (True, RespUpdAtomic s UpdResume{}) -> do+      let sCops = updateCOps (const cops) s+      handleResponse $ RespUpdAtomic sCops $ UpdResumeServer sCops+    (True, RespUpdAtomic _ UpdRestart{}) ->       when hasUI $ msgAdd "Ignoring an old savefile and starting a new game."-    (False, RespUpdAtomic UpdResume{}) ->+    (False, RespUpdAtomic _ UpdResume{}) ->       error $ "Savefile of client " ++ show side ++ " not usable."               `showFailure` ()-    (False, RespUpdAtomic UpdRestart{}) -> return ()+    (False, RespUpdAtomic _ UpdRestart{}) -> return ()+    (True, RespUpdAtomicNoState UpdResume{}) -> undefined+    (True, RespUpdAtomicNoState UpdRestart{}) ->+      when hasUI $ msgAdd "Ignoring an old savefile and starting a new game."+    (False, RespUpdAtomicNoState UpdResume{}) ->+      error $ "Savefile of client " ++ show side ++ " not usable."+              `showFailure` ()+    (False, RespUpdAtomicNoState UpdRestart{}) -> return ()     _ -> error $ "unexpected command" `showFailure` (side, restored, cmd1)   handleResponse cmd1   -- State and client state now valid.

@@ -1,12 +1,10 @@ -- | Basic client monad and related operations. module Game.LambdaHack.Client.MonadClient-  ( -- * Basic client monad-    MonadClient( getsClient, modifyClient+  ( -- * Basic client monads+    MonadClient( getsClient+               , modifyClient                , liftIO  -- exposed only to be implemented, not used                )-  , MonadClientSetup( saveClient-                    , restartClient-                    )     -- * Assorted primitives   , getClient, putClient   , debugPossiblyPrint, rndToAction, rndToActionForget@@ -18,14 +16,15 @@  import qualified Control.Monad.Trans.State.Strict as St import qualified Data.Text.IO as T-import System.IO (hFlush, stdout)+import           System.IO (hFlush, stdout) import qualified System.Random as R +import Game.LambdaHack.Client.ClientOptions import Game.LambdaHack.Client.State-import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Random +-- | Monad for writing to client state. class MonadStateRead m => MonadClient m where   getsClient    :: (StateClient -> a) -> m a   modifyClient  :: (StateClient -> StateClient) -> m ()@@ -33,10 +32,6 @@   -- nobody can subvert the action monads by invoking arbitrary IO.   liftIO        :: IO a -> m a -class MonadClient m => MonadClientSetup m where-  saveClient    :: m ()-  restartClient :: m ()- getClient :: MonadClient m => m StateClient getClient = getsClient id @@ -45,7 +40,7 @@  debugPossiblyPrint :: MonadClient m => Text -> m () debugPossiblyPrint t = do-  sdbgMsgCli <- getsClient $ sdbgMsgCli . sdebugCli+  sdbgMsgCli <- getsClient $ sdbgMsgCli . soptions   when sdbgMsgCli $ liftIO $  do     T.hPutStrLn stdout t     hFlush stdout@@ -55,7 +50,7 @@ rndToAction r = do   gen <- getsClient srandom   let (gen1, gen2) = R.split gen-  modifyClient $ \ser -> ser {srandom = gen1}+  modifyClient $ \cli -> cli {srandom = gen1}   return $! St.evalState r gen2  -- | Invoke pseudo-random computation, don't change generator kept in state.

@@ -1,9 +1,11 @@--- | Actor preferences for targets and actions based on actor attributes.+-- | Actor preferences for targets and actions, based on actor attributes. module Game.LambdaHack.Client.Preferences   ( totalUsefulness #ifdef EXPOSE_INTERNAL     -- * Internal operations-  , effectToBenefit, organBenefit, aspectToBenefit, recordToBenefit+  , effectToBenefit+  , averageTurnValue, avgItemDelay, avgItemLife, durabilityMult+  , organBenefit, recBenefit, fakeItem, aspectToBenefit, recordToBenefit #endif   ) where @@ -12,17 +14,17 @@ import Game.LambdaHack.Common.Prelude  import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Frequency-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Flavour+import           Game.LambdaHack.Common.Frequency+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ItemKind (ItemKind)+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Content.ModeKind  -- | How much AI benefits from applying the effect. -- The first component is benefit when applied to self, the second@@ -36,7 +38,7 @@ -- So there is less than @averageTurnValue@ included in each benefit, -- so in case when turn is not spent, e.g, periodic or temporary effects, -- the difference in value is only slight.-effectToBenefit :: Kind.COps -> Faction -> IK.Effect -> (Int, Int)+effectToBenefit :: Kind.COps -> Faction -> IK.Effect -> (Double, Double) effectToBenefit cops fact eff =   let delta x = (x, x)   in case eff of@@ -47,12 +49,16 @@     IK.Explode _ -> delta 1  -- depends on explosion, but usually good,                              -- unless under OnSmash, but they are ignored     IK.RefillHP p ->-      delta $ if p > 0 then min 2000 (20 * p) else max (-1000) (10 * p)+      delta $ if p > 0+              then min 2000 (20 * fromIntegral p)+              else max (-1000) (10 * fromIntegral p)         -- one HP healed is worth a bit more than one HP dealed to enemy,         -- because if the actor survives, he may deal damage many times;         -- however, AI is mostly for non-heroes that fight in suicidal crowds,         -- so the two values are kept close enough to maintain berserk approach-    IK.RefillCalm p -> delta $ if p > 0 then min 9 p else max (-9) p+    IK.RefillCalm p -> delta $ if p > 0+                               then min 9 (fromIntegral p)+                               else max (-9) (fromIntegral p)     IK.Dominate -> (0, -300)  -- I obtained an actor with, say 10HP,                               -- worth 200, and enemy lost him, another 100     IK.Impress -> (5, -50)  -- usually has no effect on self, hence low value@@ -75,7 +81,7 @@     IK.Paralyze d -> delta $ -20 * Dice.meanDice d  -- clips     IK.InsertMove d -> delta $ 100 * Dice.meanDice d  -- turns     IK.Teleport d -> if Dice.meanDice d <= 8-                     then (1, 0)   -- blink to shoot at foes+                     then (1, 0)     -- blink to shoot at foes                      else (-9, -1)  -- for self, don't derail exploration                                     -- for foes, fight with one less at a time     IK.CreateItem COrgan "temporary condition" _ ->@@ -86,8 +92,9 @@             IK.TimerGameTurn n -> Dice.meanDice n             IK.TimerActorTurn n -> Dice.meanDice n           (total, count) = organBenefit turnTimer grp cops fact-      in delta $ total `divUp` count  -- the same when created in me and in foe-        -- average over all matching grps; simplified: rarities ignored+      in delta $ total / fromIntegral count+           -- the same when created in me and in foe+           -- average over all matching grps; simplified: rarities ignored     IK.CreateItem _ "treasure" _ -> (100, 0)  -- assumed not temporary     IK.CreateItem _ "useful" _ -> (70, 0)     IK.CreateItem _ "any scroll" _ -> (50, 0)@@ -96,7 +103,7 @@     IK.CreateItem _ "flask" _ -> (50, 0)     IK.CreateItem _ grp _ ->  -- assumed not temporary and @grp@ tiny       let (total, count) = recBenefit grp cops fact-      in (total `divUp` count, 0)+      in (total / fromIntegral count, 0)     IK.DropItem _ _ COrgan "temporary condition" ->       (1, -1)  -- varied, big bunch, but try to nullify it anyway     IK.DropItem ngroup kcopy COrgan grp ->  -- assumed temporary@@ -110,15 +117,16 @@           (total, count) = organBenefit turnTimer grp cops fact           boundBonus n = if n == maxBound then 10 else 0       in delta $ boundBonus ngroup + boundBonus kcopy-                 - total `divUp` count  -- the same when dropped from me and foe+                 - total / fromIntegral count+                   -- the same when dropped from me and foe     IK.DropItem{} -> delta (-10)  -- depends a lot on what is dropped     IK.PolyItem -> delta 0  -- AI can't estimate item desirability vs average     IK.Identify -> delta 0  -- AI doesn't know how to use-    IK.Detect radius -> (radius * 2, 0)-    IK.DetectActor radius -> (radius, 0)-    IK.DetectItem radius -> (radius, 0)-    IK.DetectExit radius -> (radius, 0)-    IK.DetectHidden radius -> (radius, 0)+    IK.Detect radius -> (fromIntegral radius * 2, 0)+    IK.DetectActor radius -> (fromIntegral radius, 0)+    IK.DetectItem radius -> (fromIntegral radius, 0)+    IK.DetectExit radius -> (fromIntegral radius, 0)+    IK.DetectHidden radius -> (fromIntegral radius, 0)     IK.SendFlying _ -> (1, -10)  -- very context dependent, but it's better     IK.PushActor _ -> (1, -10)   -- to be the one that decides and not the one     IK.PullActor _ -> (1, -10)   -- that is interrupted in the middle of fleeing@@ -130,16 +138,22 @@       let bs = map (effectToBenefit cops fact) efs           f (self, foe) (accSelf, accFoe) = (self + accSelf, foe + accFoe)           (effSelf, effFoe) = foldr f (0, 0) bs-      in (effSelf `divUp` length bs, effFoe `divUp` length bs)+      in (effSelf / fromIntegral (length bs), effFoe / fromIntegral (length bs))     IK.OnSmash _ -> delta 0       -- can be beneficial; we'd need to analyze explosions, range, etc.     IK.Recharging _ -> delta 0  -- taken into account separately     IK.Temporary _ -> delta 0  -- assumed for created organs only     IK.Unique -> delta 0     IK.Periodic -> delta 0  -- considered in totalUsefulness+    IK.Composite [] -> delta 0+    IK.Composite (eff1 : _) -> effectToBenefit cops fact eff1+      -- for simplicity; so in content make sure to place initial animations+      -- among normal effects, not at the start of composite effect+      -- (animations should not fail, after all), and start composite+      -- effect with the main thing  -- See the comment for @Paralyze@.-averageTurnValue :: Int+averageTurnValue :: Double averageTurnValue = 10  -- Average delay between desired item uses. Some items are best activated@@ -156,7 +170,7 @@ -- We don't want to undervalue rarely used items with long timeouts -- and we think that most interesting gameplay comes from alternating -- item use, so we arbitrarily set the full value timeout to 3.-avgItemDelay :: Int+avgItemDelay :: Double avgItemDelay = 3  -- The average time between item being found (and enough skill obtained@@ -173,14 +187,14 @@ -- We set the value to 30, assuming if the actor finds an item, then he is -- most likely at an unlooted level, so he will find more loot soon, -- or he is in a battle, so he will die soon (or win even more loot).-avgItemLife :: Int+avgItemLife :: Double avgItemLife = 30  -- The value of durable item is this many times higher than non-durable, -- because the item will on average be activated this many times -- before it stops being used.-durabilityMult :: Int-durabilityMult = avgItemLife `div` avgItemDelay+durabilityMult :: Double+durabilityMult = avgItemLife / avgItemDelay  -- We assume the organ is temporary (@Temporary@, @Periodic@, @Timeout 0@) -- and also that it doesn't provide any functionality, e.g., detection@@ -212,19 +226,20 @@ -- are applied and we can't stop/restart them. -- -- We assume, only one of timer and count mechanisms is present at once.-organBenefit :: Int -> GroupName ItemKind -> Kind.COps -> Faction -> (Int, Int)+organBenefit :: Double -> GroupName ItemKind -> Kind.COps -> Faction+             -> (Double, Int) organBenefit turnTimer grp cops@Kind.COps{coitem=Kind.Ops{ofoldlGroup'}} fact =   let f (!sacc, !pacc) !p _ !kind =-        let paspect asp = p * aspectToBenefit asp-            peffect eff = p * fst (effectToBenefit cops fact eff)+        let paspect asp = fromIntegral p * aspectToBenefit asp+            peffect eff = fromIntegral p * fst (effectToBenefit cops fact eff)         in ( sacc + Dice.meanDice (IK.icount kind)                     * (sum (map paspect $ IK.iaspects kind)                        + sum (map peffect $ stripRecharging $ IK.ieffects kind))-                  - averageTurnValue `div` turnTimer+                  - averageTurnValue / turnTimer            , pacc + p )   in ofoldlGroup' grp f (0, 0) -recBenefit :: GroupName ItemKind -> Kind.COps -> Faction -> (Int, Int)+recBenefit :: GroupName ItemKind -> Kind.COps -> Faction -> (Double, Int) recBenefit grp cops@Kind.COps{coitem=Kind.Ops{ofoldlGroup'}} fact =   let f (!sacc, !pacc) !p _ !kind =         let recPickup = benPickup $@@ -267,15 +282,15 @@ -- Valuation of effects, and more precisely, more the signs than absolute -- values, ensures that both shield and torch get picked up so that -- the (human) actor can nevertheless equip them in very special cases.-aspectToBenefit :: IK.Aspect -> Int+aspectToBenefit :: IK.Aspect -> Double aspectToBenefit asp =   case asp of     IK.Timeout{} -> 0     IK.AddHurtMelee p -> Dice.meanDice p  -- offence favoured-    IK.AddArmorMelee p -> Dice.meanDice p `divUp` 4  -- only partial protection-    IK.AddArmorRanged p -> Dice.meanDice p `divUp` 8+    IK.AddArmorMelee p -> Dice.meanDice p / 4  -- only partial protection+    IK.AddArmorRanged p -> Dice.meanDice p / 8     IK.AddMaxHP p -> Dice.meanDice p-    IK.AddMaxCalm p -> Dice.meanDice p `divUp` 5+    IK.AddMaxCalm p -> Dice.meanDice p / 5     IK.AddSpeed p -> Dice.meanDice p * 25       -- 1 speed ~ 5% melee; times 5 for no caps, escape, pillar-dancing, etc.;       -- also, it's 1 extra turn each 20 turns, so 100/20, so 5; figures@@ -286,10 +301,13 @@     IK.AddAggression{} -> 0     IK.AddAbility _ p -> Dice.meanDice p * 5 -recordToBenefit :: AspectRecord -> [Int]+recordToBenefit :: AspectRecord -> [Double] recordToBenefit aspects = map aspectToBenefit $ aspectRecordToList aspects --- Result has non-strict fields, so arguments are forced to avoid leaks.+-- | Compute the whole 'Benefit' structure, containing various facets+-- of AI item preference, for an item with the given effects and aspects.+--+-- Note: result has non-strict fields, so arguments are forced to avoid leaks. -- When AI looks at items (including organs) more often, force the fields. totalUsefulness :: Kind.COps -> Faction -> [IK.Effect] -> AspectRecord -> Item                 -> Benefit@@ -309,8 +327,9 @@         let scaleChargeBens bens               | timeout <= 3 = bens               | otherwise = map (\eff ->-                  if avgItemDelay >= timeout then eff-                  else eff * avgItemDelay `divUp` timeout) bens+                  if avgItemDelay >= fromIntegral timeout+                  then eff+                  else eff * avgItemDelay / fromIntegral timeout) bens             (cself, cfoe) = unzip $ map (effectToBenefit cops fact)                                         (stripRecharging effects)         in (scaleChargeBens cself, scaleChargeBens cfoe)@@ -348,12 +367,12 @@       benApply = max 0 $  -- because optional; I don't need to apply         (effSelf + effDice  -- hits self with dice too, when applying          + if periodic then 0 else sum chargeSelf)-        `divUp` if durable then 1 else durabilityMult+        / if durable then 1 else durabilityMult       -- For melee, we add the foe part.       benMelee = min 0 $         (effFoe + effDice  -- @AddHurtMelee@ already in @eqpSum@          + if periodic then 0 else sum chargeFoe)-        `divUp` if durable then 1 else durabilityMult+        / if durable then 1 else durabilityMult       -- The periodic effects, if any, are activated when projectile flies,       -- but not when it hits, so they are not added to @benFling@.       -- However, if item is not periodic, the recharging effects@@ -361,17 +380,17 @@       benFling = min 0 $         effFoe + benFlingDice -- nothing in @eqpSum@; normally not worn         + if periodic then 0 else sum chargeFoe-      benFlingDice | jdamage item <= 0 = 0  -- speedup+      benFlingDice | jdamage item == 0 = 0  -- speedup                    | otherwise = assert (v <= 0) v        where         hurtMult = 100 + min 99 (max (-99) (aHurtMelee aspects))           -- assumes no enemy armor and no block         dmg = Dice.meanDice (jdamage item)-        rawDeltaHP = fromIntegral hurtMult * xM dmg `divUp` 100+        rawDeltaHP = ceiling $ fromIntegral hurtMult * xD dmg / 100         -- For simplicity, we ignore range bonus/malus and @Lobable@.         IK.ThrowMod{IK.throwVelocity} = strengthToThrow item         speed = speedFromWeight (jweight item) throwVelocity-        v = fromEnum $ - modifyDamageBySpeed rawDeltaHP speed * 10 `div` oneM+        v = - fromIntegral (modifyDamageBySpeed rawDeltaHP speed) * 10 / xD 1           -- 1 damage valued at 10, just as in @damageUsefulness@       -- For equipment benefit, we take into account only the self       -- value of the recharging effects, because they applied to self.

@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds, GADTs, KindSignatures, StandaloneDeriving #-}+-- | Abstract syntax of requests.+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Client.Request+  ( RequestAI, ReqAI(..), RequestUI, ReqUI(..)+  , RequestAnyAbility(..), RequestTimed(..)+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Game.LambdaHack.Common.Ability+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Misc+import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ModeKind++-- | Requests sent by AI clients to the server. If faction leader is to be+-- changed, it's included as the second component.+type RequestAI = (ReqAI, Maybe ActorId)++-- | Possible forms of requests sent by AI clients.+data ReqAI =+    ReqAINop+  | ReqAITimed RequestAnyAbility+  deriving Show++-- | Requests sent by UI clients to the server. If faction leader is to be+-- changed, it's included as the second component.+type RequestUI = (ReqUI, Maybe ActorId)++-- | Possible forms of requests sent by UI clients.+data ReqUI =+    ReqUINop+  | ReqUITimed RequestAnyAbility+  | ReqUIGameRestart (GroupName ModeKind) Challenge+  | ReqUIGameExit+  | ReqUIGameSave+  | ReqUITactic Tactic+  | ReqUIAutomate+  deriving Show++-- | Basic form of requests, sent by both AI and UI clients to the server.+data RequestAnyAbility = forall a. RequestAnyAbility (RequestTimed a)++deriving instance Show RequestAnyAbility++-- | Requests that take game time, indexed by actor ability+-- that is needed for performing the corresponding actions.+data RequestTimed :: Ability -> * where+  ReqMove :: Vector -> RequestTimed 'AbMove+  ReqMelee :: ActorId -> ItemId -> CStore -> RequestTimed 'AbMelee+  ReqDisplace :: ActorId -> RequestTimed 'AbDisplace+  ReqAlter :: Point -> RequestTimed 'AbAlter+  ReqWait :: RequestTimed 'AbWait+  ReqWait10 :: RequestTimed 'AbWait+  ReqMoveItems :: [(ItemId, Int, CStore, CStore)] -> RequestTimed 'AbMoveItem+  ReqProject :: Point -> Int -> ItemId -> CStore -> RequestTimed 'AbProject+  ReqApply :: ItemId -> CStore -> RequestTimed 'AbApply++deriving instance Show (RequestTimed a)

@@ -0,0 +1,33 @@+-- | Abstract syntax of responses.+--+-- See+-- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>.+module Game.LambdaHack.Client.Response+  ( Response(..)+  ) where++import Prelude ()++import Game.LambdaHack.Common.Prelude++import Game.LambdaHack.Atomic+import Game.LambdaHack.Common.Actor+import Game.LambdaHack.Common.State++-- | Abstract syntax of responses sent by server to an AI or UI client+-- (or a universal client that can handle both roles, which is why+-- this type is not separated into distinct AI and UI types).+-- A response tells a client how to update game state or what information+-- to send to the server.+data Response =+    RespUpdAtomicNoState UpdAtomic+    -- ^ change @State@ by performing this atomic update+  | RespUpdAtomic State UpdAtomic+    -- ^ put the given @State@, which results from performing the atomic update+  | RespQueryAI ActorId+    -- ^ compute an AI move for the actor and send (the semantics of) it+  | RespSfxAtomic SfxAtomic+    -- ^ perform special effects (animations, messages, etc.)+  | RespQueryUI+    -- ^ prompt the human player for a command and send (the semantics of) it+  deriving Show

@@ -1,82 +1,72 @@ {-# LANGUAGE DeriveGeneric #-}--- | Server and client game state types and operations.+-- | Client-specific game state components. module Game.LambdaHack.Client.State-  ( StateClient(..), emptyStateClient-  , AlterLid-  , updateTarget, getTarget, updateLeader, sside-  , BfsAndPath(..), TgtAndPath(..), cycleMarkSuspect+  ( StateClient(..), AlterLid, BfsAndPath(..), TgtAndPath(..)+  , emptyStateClient, cycleMarkSuspect+  , updateTarget, getTarget, updateLeader, sside, sleader   ) where  import Prelude ()  import Game.LambdaHack.Common.Prelude -import Data.Binary+import           Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M-import GHC.Generics (Generic)+import           GHC.Generics (Generic) import qualified System.Random as R -import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item+import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.ClientOptions+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind (ModeKind)+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Content.ModeKind (ModeKind)  -- | Client state, belonging to a single faction.--- Some of the data, e.g, the history, carries over--- from game to game, even across playing sessions.------ When many actors want to fling at the same target, they set--- their personal targets to follow the common xhair.--- When each wants to kill a fleeing enemy they recently meleed,--- they keep the enemies as their personal targets.------ Data invariant: if @_sleader@ is @Nothing@ then so is @srunning@. data StateClient = StateClient-  { seps          :: Int           -- ^ a parameter of the aiming digital line+  { seps          :: Int            -- ^ a parameter of the aiming digital line   , stargetD      :: EM.EnumMap ActorId TgtAndPath-                                   -- ^ targets of our actors in the dungeon+                                    -- ^ targets of our actors in the dungeon   , sexplored     :: ES.EnumSet LevelId-                                   -- ^ the set of fully explored levels+                                    -- ^ the set of fully explored levels   , sbfsD         :: EM.EnumMap ActorId BfsAndPath-                                   -- ^ pathfinding distances for our actors-                                   --   and paths to their targets, if any-  , sundo         :: [CmdAtomic]   -- ^ atomic commands performed to date-  , sdiscoKind    :: DiscoveryKind     -- ^ remembered item discoveries-  , sdiscoAspect  :: DiscoveryAspect   -- ^ remembered aspects of items-  , sdiscoBenefit :: DiscoveryBenefit  -- ^ remembered AI benefits of items-  , sactorAspect  :: ActorAspect   -- ^ best known actor aspect data-  , sfper         :: PerLid        -- ^ faction perception indexed by levels-  , salter        :: AlterLid      -- ^ cached alter ability data for positions-  , srandom       :: R.StdGen      -- ^ current random generator-  , _sleader      :: Maybe ActorId-                                   -- ^ candidate new leader of the faction;-                                   --   Faction._gleader is the old leader-  , _sside        :: FactionId     -- ^ faction controlled by the client-  , squit         :: Bool          -- ^ exit the game loop-  , scurChal      :: Challenge     -- ^ current game challenge setup-  , snxtChal      :: Challenge     -- ^ next game challenge setup-  , snxtScenario  :: Int           -- ^ next game scenario number-  , smarkSuspect  :: Int           -- ^ mark suspect features+                                    -- ^ pathfinding data for our actors+  , sundo         :: [CmdAtomic]    -- ^ atomic commands performed to date+  , sdiscoBenefit :: DiscoveryBenefit+                                    -- ^ remembered AI benefits of items+  , sfper         :: PerLid         -- ^ faction perception indexed by level+  , salter        :: AlterLid       -- ^ cached alter ability data for positions+  , srandom       :: R.StdGen       -- ^ current random generator+  , _sleader      :: Maybe ActorId  -- ^ candidate new leader of the faction;+                                    --   Faction.gleader is the old leader+  , _sside        :: FactionId      -- ^ faction controlled by the client+  , squit         :: Bool           -- ^ exit the game loop+  , scurChal      :: Challenge      -- ^ current game challenge setup+  , snxtChal      :: Challenge      -- ^ next game challenge setup+  , snxtScenario  :: Int            -- ^ next game scenario number+  , smarkSuspect  :: Int            -- ^ whether to mark suspect features   , scondInMelee  :: EM.EnumMap LevelId (Maybe Bool)-                                   -- ^ condInMelee value, unless invalidated+                                    -- ^ last in-melee condition for each level   , svictories    :: EM.EnumMap (Kind.Id ModeKind) (M.Map Challenge Int)-      -- ^ won games at particular difficulty levels-  , sdebugCli     :: DebugModeCli  -- ^ client debugging mode+                                    -- ^ won games at particular difficulty lvls+  , soptions      :: ClientOptions  -- ^ client options   }   deriving Show +type AlterLid = EM.EnumMap LevelId (PointArray.Array Word8)++-- | Pathfinding distances to all reachable positions of an actor+-- and a shortest paths to some of the positions. data BfsAndPath =     BfsInvalid   | BfsAndPath { bfsArr  :: PointArray.Array BfsDistance@@ -84,13 +74,12 @@                }   deriving Show +-- | Actor's target and a path to it, if any. data TgtAndPath = TgtAndPath {tapTgt :: Target, tapPath :: AndPath}   deriving (Show, Generic)  instance Binary TgtAndPath -type AlterLid = EM.EnumMap LevelId (PointArray.Array Word8)- -- | Initial empty game client state. emptyStateClient :: FactionId -> StateClient emptyStateClient _sside =@@ -100,10 +89,7 @@     , sexplored = ES.empty     , sbfsD = EM.empty     , sundo = []-    , sdiscoKind = EM.empty-    , sdiscoAspect = EM.empty     , sdiscoBenefit = EM.empty-    , sactorAspect = EM.empty     , sfper = EM.empty     , salter = EM.empty     , srandom = R.mkStdGen 42  -- will get modified in this and future games@@ -116,9 +102,10 @@     , smarkSuspect = 1     , scondInMelee = EM.empty     , svictories = EM.empty-    , sdebugCli = defDebugModeCli+    , soptions = defClientOptions     } +-- | Cycle the 'smarkSuspect' setting. cycleMarkSuspect :: StateClient -> StateClient cycleMarkSuspect s@StateClient{smarkSuspect} =   s {smarkSuspect = (smarkSuspect + 1) `mod` 3}@@ -148,14 +135,15 @@ sside :: StateClient -> FactionId sside = _sside +sleader :: StateClient -> Maybe ActorId+sleader = _sleader+ instance Binary StateClient where   put StateClient{..} = do     put seps     put stargetD     put sexplored     put sundo-    put sdiscoKind-    put sdiscoAspect     put sdiscoBenefit     put (show srandom)     put _sleader@@ -166,7 +154,7 @@     put smarkSuspect     put scondInMelee     put svictories-    put sdebugCli+    put soptions #ifdef WITH_EXPENSIVE_ASSERTIONS     put sfper #endif@@ -175,8 +163,6 @@     stargetD <- get     sexplored <- get     sundo <- get-    sdiscoKind <- get-    sdiscoAspect <- get     sdiscoBenefit <- get     g <- get     _sleader <- get@@ -187,9 +173,8 @@     smarkSuspect <- get     scondInMelee <- get     svictories <- get-    sdebugCli <- get+    soptions <- get     let sbfsD = EM.empty-        sactorAspect = EM.empty         salter = EM.empty         srandom = read g         squit = False

@@ -2,19 +2,17 @@ -- requests, based on the client's view (visualized for the player) -- of the game state. module Game.LambdaHack.Client.UI-  ( -- * Client UI monad-    MonadClientUI(..)-    -- * Assorted UI operations-  , putSession, queryUI+  ( -- * Querying the human player+    queryUI+    -- * UI monad and session type+  , MonadClientUI(..), SessionUI(..)+    -- * Updating UI state wrt game state changes   , displayRespUpdAtomicUI, displayRespSfxAtomicUI-    -- * Startup-  , KeyKind, SessionUI(..), emptySessionUI-  , Config, applyConfigToDebug, configCmdline, mkConfig-  , ChanFrontend, chanFrontend, frontendShutdown-    -- * Operations exposed for LoopClient-  , ColorMode(..)-  , reportToSlideshow, getConfirms, msgAdd, promptAdd, addPressedEsc-  , tryRestore, stdBinding+    -- * Startup and initialization+  , KeyKind+  , UIOptions, applyUIOptions, uCmdline, mkUIOptions+    -- * Operations exposed for "Game.LambdaHack.Client.LoopM"+  , ChanFrontend, chanFrontend, msgAdd, tryRestore, stdBinding #ifdef EXPOSE_INTERNAL     -- * Internal operations   , humanCommand@@ -30,35 +28,34 @@ import qualified Data.Map.Strict as M import qualified Data.Text as T -import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.Content.KeyKind-import Game.LambdaHack.Client.UI.DisplayAtomicM-import Game.LambdaHack.Client.UI.FrameM-import Game.LambdaHack.Client.UI.Frontend-import Game.LambdaHack.Client.UI.HandleHelperM-import Game.LambdaHack.Client.UI.HandleHumanM+import           Game.LambdaHack.Client.ClientOptions+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.Request+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.Content.KeyKind+import           Game.LambdaHack.Client.UI.DisplayAtomicM+import           Game.LambdaHack.Client.UI.FrameM+import           Game.LambdaHack.Client.UI.Frontend+import           Game.LambdaHack.Client.UI.HandleHelperM+import           Game.LambdaHack.Client.UI.HandleHumanM import qualified Game.LambdaHack.Client.UI.Key as K-import Game.LambdaHack.Client.UI.KeyBindings-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.Msg-import Game.LambdaHack.Client.UI.MsgM-import Game.LambdaHack.Client.UI.Overlay-import Game.LambdaHack.Client.UI.OverlayM-import Game.LambdaHack.Client.UI.SessionUI-import Game.LambdaHack.Client.UI.Slideshow-import Game.LambdaHack.Client.UI.SlideshowM-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State-import Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Client.UI.KeyBindings+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.Slideshow+import           Game.LambdaHack.Client.UI.SlideshowM+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.State+import           Game.LambdaHack.Content.ModeKind --- | Handle the move of a UI player.+-- | Handle the move of a human player. queryUI :: MonadClientUI m => m RequestUI queryUI = do   side <- getsClient sside@@ -71,16 +68,16 @@       addPressedEsc       -- Regaining control of faction cancels --stopAfter*.       modifyClient $ \cli ->-        cli {sdebugCli = (sdebugCli cli) { sstopAfterSeconds = Nothing+        cli {soptions = (soptions cli) { sstopAfterSeconds = Nothing                                          , sstopAfterFrames = Nothing }}       return (ReqUIAutomate, Nothing)  -- stop AI     else do       -- As long as UI faction is under AI control, check, once per move,       -- for benchmark game stop.-      stopAfterFrames <- getsClient $ sstopAfterFrames . sdebugCli+      stopAfterFrames <- getsClient $ sstopAfterFrames . soptions       case stopAfterFrames of         Nothing -> do-          stopAfterSeconds <- getsClient $ sstopAfterSeconds . sdebugCli+          stopAfterSeconds <- getsClient $ sstopAfterSeconds . soptions           case stopAfterSeconds of             Nothing -> return (ReqUINop, Nothing)             Just stopS -> do@@ -97,7 +94,7 @@             return (ReqUIGameExit, Nothing)  -- ask server to exit           else return (ReqUINop, Nothing)   else do-    let mleader = _gleader fact+    let mleader = gleader fact         !_A = assert (isJust mleader) ()     req <- humanCommand     leader2 <- getLeaderUI@@ -106,16 +103,16 @@ -- | Let the human player issue commands until any command takes time. humanCommand :: forall m. MonadClientUI m => m ReqUI humanCommand = do-  modifySession $ \sess -> sess {slastLost = ES.empty}-  modifySession $ \sess -> sess {skeysHintMode = KeysHintAbsent}+  modifySession $ \sess -> sess { slastLost = ES.empty+                                , skeysHintMode = KeysHintAbsent }   let loop :: m ReqUI       loop = do-        report <- getsSession _sreport+        report <- getsSession sreport         if nullReport report then do           -- Display keys sometimes, alternating with empty screen.           keysHintMode <- getsSession skeysHintMode           case keysHintMode of-            KeysHintPresent -> describeMainKeys >>= promptAdd+            KeysHintPresent -> promptMainKeys             KeysHintBlocked ->               modifySession $ \sess -> sess {skeysHintMode = KeysHintAbsent}             _ -> return ()@@ -134,9 +131,10 @@               void $ getConfirms ColorFull [K.spaceKM, K.escKM] slidesRaw               -- Display base frame at the end.               return []-        (seqCurrent, seqPrevious, k) <- getsSession slastRecord-        let slastRecord | k == 0 = ([], seqCurrent, 0)-                        | otherwise = ([], seqCurrent ++ seqPrevious, k - 1)+        LastRecord seqCurrent seqPrevious k <- getsSession slastRecord+        let slastRecord+              | k == 0 = LastRecord [] seqCurrent 0+              | otherwise = LastRecord [] (seqCurrent ++ seqPrevious) (k - 1)         modifySession $ \sess -> sess {slastRecord}         lastPlay <- getsSession slastPlay         leader <- getLeaderUI

@@ -4,24 +4,24 @@   ( ActorUI(..), ActorDictUI   , keySelected, partActor, partPronoun   , ppContainer, ppCStore, ppCStoreIn, ppCStoreWownW-  , ppContainerWownW, verbCStore, tryFindHeroK+  , ppContainerWownW, verbCStore, tryFindActor, tryFindHeroK   ) where  import Prelude ()  import Game.LambdaHack.Common.Prelude -import Data.Binary+import           Data.Binary import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM-import GHC.Generics (Generic)+import           GHC.Generics (Generic) import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.State  data ActorUI = ActorUI   { bsymbol  :: Char         -- ^ individual map symbol@@ -88,7 +88,6 @@ verbCStore CInv = "pack" verbCStore CSha = "stash" --- | Tries to finds an actor body satisfying a predicate on any level. tryFindActor :: State -> (ActorId -> Actor -> Bool) -> Maybe (ActorId, Actor) tryFindActor s p = find (uncurry p) $ EM.assocs $ sactorD s 

@@ -2,14 +2,18 @@ module Game.LambdaHack.Client.UI.Animation   ( Animation, renderAnim   , pushAndDelay, blinkColorActor, twirlSplash, blockHit, blockMiss-  , deathBody, shortDeathBody, actorX, swapPlaces, teleport, fadeout+  , deathBody, shortDeathBody, actorX, teleport, swapPlaces, fadeout+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , blank, cSym, mapPosToOffset, mzipSingleton, mzipPairs+#endif   ) where  import Prelude ()  import Game.LambdaHack.Common.Prelude -import Data.Bits+import           Data.Bits import qualified Data.EnumMap.Strict as EM  import Game.LambdaHack.Client.UI.Frame@@ -21,15 +25,17 @@  -- | Animation is a list of frame modifications to play one by one, -- where each modification if a map from positions to level map symbols.-newtype Animation = Animation [Overlay]+newtype Animation = Animation [IntOverlay]   deriving (Eq, Show)  -- | Render animations on top of a screen frame.+--+-- Located in this module to keep @Animation@ abstract. renderAnim :: FrameForall -> Animation -> Frames renderAnim basicFrame (Animation anim) =-  let modifyFrame :: Overlay -> FrameForall+  let modifyFrame :: IntOverlay -> FrameForall       modifyFrame am = overlayFrame am basicFrame-      modifyFrames :: (Overlay, Overlay) -> Maybe FrameForall+      modifyFrames :: (IntOverlay, IntOverlay) -> Maybe FrameForall       modifyFrames (am, amPrevious) =         if am == amPrevious then Nothing else Just $ modifyFrame am   in Just basicFrame : map modifyFrames (zip anim ([] : anim))@@ -45,13 +51,13 @@   let lxsize = fst normalLevelBound + 1   in ((py + 1) * lxsize + px, [attr]) -mzipSingleton :: Point -> Maybe AttrCharW32 -> Overlay+mzipSingleton :: Point -> Maybe AttrCharW32 -> IntOverlay mzipSingleton p1 mattr1 = map mapPosToOffset $   let mzip (pos, mattr) = fmap (\attr -> (pos, attr)) mattr   in catMaybes [mzip (p1, mattr1)]  mzipPairs :: (Point, Point) -> (Maybe AttrCharW32, Maybe AttrCharW32)-          -> Overlay+          -> IntOverlay mzipPairs (p1, p2) (mattr1, mattr2) = map mapPosToOffset $   let mzip (pos, mattr) = fmap (\attr -> (pos, attr)) mattr   in catMaybes $ if p1 /= p2

@@ -1,145 +0,0 @@-{-# LANGUAGE DeriveGeneric, FlexibleContexts #-}--- | Personal game configuration file type definitions.-module Game.LambdaHack.Client.UI.Config-  ( Config(..), mkConfig, applyConfigToDebug-  ) where--import Prelude ()--import Game.LambdaHack.Common.Prelude--import Control.DeepSeq-import Data.Binary-import qualified Data.Ini as Ini-import qualified Data.Ini.Reader as Ini-import qualified Data.Ini.Types as Ini-import qualified Data.Map.Strict as M-import Game.LambdaHack.Common.ClientOptions-import GHC.Generics (Generic)-import System.FilePath-import Text.Read--import Game.LambdaHack.Client.UI.HumanCmd-import qualified Game.LambdaHack.Client.UI.Key as K-import Game.LambdaHack.Common.File-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Content.RuleKind---- | Fully typed contents of the UI config file. This config--- is a part of a game client.-data Config = Config-  { -- commands-    configCommands      :: [(K.KM, CmdTriple)]-    -- hero names-  , configHeroNames     :: [(Int, (Text, Text))]-    -- ui-  , configVi            :: Bool  -- ^ the option for Vi keys takes precendence-  , configLaptop        :: Bool  -- ^ because the laptop keys are the default-  , configGtkFontFamily :: Text-  , configSdlFontFile   :: Text-  , configSdlTtfSizeAdd :: Int-  , configSdlFonSizeAdd :: Int-  , configFontSize      :: Int-  , configColorIsBold   :: Bool-  , configHistoryMax    :: Int-  , configMaxFps        :: Int-  , configNoAnim        :: Bool-  , configRunStopMsgs   :: Bool-  , configCmdline       :: [String]-  }-  deriving (Show, Generic)--instance NFData Config--instance Binary Config--parseConfig :: Ini.Config -> Config-parseConfig cfg =-  let configCommands =-        let mkCommand (ident, keydef) =-              case stripPrefix "Cmd_" ident of-                Just _ ->-                  let (key, def) = read keydef-                  in (K.mkKM key, def :: CmdTriple)-                Nothing -> error $ "wrong macro id" `showFailure` ident-            section = Ini.allItems "extra_commands" cfg-        in map mkCommand section-      configHeroNames =-        let toNumber (ident, nameAndPronoun) =-              case stripPrefix "HeroName_" ident of-                Just n -> (read n, read nameAndPronoun)-                Nothing -> error $ "wrong hero name id" `showFailure` ident-            section = Ini.allItems "hero_names" cfg-        in map toNumber section-      getOption :: forall a. Read a => String -> a-      getOption optionName =-        let lookupFail :: forall b. String -> b-            lookupFail err =-              error $ "config file access failed"-                      `showFailure` (err, optionName, cfg)-            s = fromMaybe (lookupFail "") $ Ini.getOption "ui" optionName cfg-        in either lookupFail id $ readEither s-      configVi = getOption "movementViKeys_hjklyubn"-      -- The option for Vi keys takes precendence,-      -- because the laptop keys are the default.-      configLaptop = not configVi && getOption "movementLaptopKeys_uk8o79jl"-      configGtkFontFamily = getOption "gtkFontFamily"-      configSdlFontFile = getOption "sdlFontFile"-      configSdlTtfSizeAdd = getOption "sdlTtfSizeAdd"-      configSdlFonSizeAdd = getOption "sdlFonSizeAdd"-      configFontSize = getOption "fontSize"-      configColorIsBold = getOption "colorIsBold"-      configHistoryMax = getOption "historyMax"-      configMaxFps = max 1 $ getOption "maxFps"-      configNoAnim = getOption "noAnim"-      configRunStopMsgs = getOption "runStopMsgs"-      configCmdline = words $ getOption "overrideCmdline"-  in Config{..}---- | Read and parse UI config file.-mkConfig :: Kind.COps -> Bool -> IO Config-mkConfig Kind.COps{corule} benchmark = do-  let stdRuleset = Kind.stdRuleset corule-      cfgUIName = rcfgUIName stdRuleset-      sUIDefault = rcfgUIDefault stdRuleset-      cfgUIDefault = either (error . ("" `showFailure`)) id-                     $ Ini.parse sUIDefault-  dataDir <- appDataDir-  let userPath = dataDir </> cfgUIName-  cfgUser <- if benchmark then return Ini.emptyConfig else do-    cpExists <- doesFileExist userPath-    if not cpExists-      then return Ini.emptyConfig-      else do-        sUser <- readFile userPath-        return $! either (error . ("" `showFailure`)) id $ Ini.parse sUser-  let cfgUI = M.unionWith M.union cfgUser cfgUIDefault  -- user cfg preferred-      conf = parseConfig cfgUI-  -- Catch syntax errors in complex expressions ASAP,-  return $! deepseq conf conf--applyConfigToDebug :: Kind.COps -> Config -> DebugModeCli -> DebugModeCli-applyConfigToDebug Kind.COps{corule} sconfig sdebugCli =-  let stdRuleset = Kind.stdRuleset corule-  in (\dbg -> dbg {sgtkFontFamily =-        sgtkFontFamily dbg `mplus` Just (configGtkFontFamily sconfig)}) .-     (\dbg -> dbg {sdlFontFile =-        sdlFontFile dbg `mplus` Just (configSdlFontFile sconfig)}) .-     (\dbg -> dbg {sdlTtfSizeAdd =-        sdlTtfSizeAdd dbg `mplus` Just (configSdlTtfSizeAdd sconfig)}) .-     (\dbg -> dbg {sdlFonSizeAdd =-        sdlFonSizeAdd dbg `mplus` Just (configSdlFonSizeAdd sconfig)}) .-     (\dbg -> dbg {sfontSize =-        sfontSize dbg `mplus` Just (configFontSize sconfig)}) .-     (\dbg -> dbg {scolorIsBold =-        scolorIsBold dbg `mplus` Just (configColorIsBold sconfig)}) .-     (\dbg -> dbg {smaxFps =-        smaxFps dbg `mplus` Just (configMaxFps sconfig)}) .-     (\dbg -> dbg {snoAnim =-        snoAnim dbg `mplus` Just (configNoAnim sconfig)}) .-     (\dbg -> dbg {stitle =-        stitle dbg `mplus` Just (rtitle stdRuleset)}) .-     (\dbg -> dbg {sfontDir =-        sfontDir dbg `mplus` Just (rfontDir stdRuleset)})-     $ sdebugCli

@@ -1,12 +1,17 @@--- | The type of key-command mappings to be used for the UI.+-- | The type of definitions of key-command mappings to be used for the UI+-- and shorthands for specifying command triples in the content files. module Game.LambdaHack.Client.UI.Content.KeyKind   ( KeyKind(..), evalKeyDef   , addCmdCategory, replaceDesc, moveItemTriple, repeatTriple   , mouseLMB, mouseMMB, mouseRMB   , goToCmd, runToAllCmd, autoexploreCmd, autoexplore25Cmd-  , aimFlingCmd, projectI, projectA, flingTs, applyI, applyIK+  , aimFlingCmd, projectI, projectA, flingTs, applyIK, applyI   , grabItems, dropItems, descTs, defaultHeroSelect-  ) where+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , replaceCmd, projectICmd, grabCmd, dropCmd+#endif+ ) where  import Prelude () @@ -15,15 +20,13 @@ import qualified Data.Char as Char import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Client.UI.ActorUI (verbCStore)-import Game.LambdaHack.Client.UI.HumanCmd+import           Game.LambdaHack.Client.UI.ActorUI (verbCStore)+import           Game.LambdaHack.Client.UI.HumanCmd import qualified Game.LambdaHack.Client.UI.Key as K-import Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Misc --- | Key-command mappings to be used for the UI.-newtype KeyKind = KeyKind-  { rhumanCommands :: [(K.KM, CmdTriple)]  -- ^ default client UI commands-  }+-- | Key-command mappings to be specified in content and used for the UI.+newtype KeyKind = KeyKind [(K.KM, CmdTriple)]  -- ^ default client UI commands  evalKeyDef :: (String, CmdTriple) -> (K.KM, CmdTriple) evalKeyDef (t, triple@(cats, _, _)) =

@@ -1,6 +1,13 @@ -- | Display atomic commands received by the client. module Game.LambdaHack.Client.UI.DisplayAtomicM   ( displayRespUpdAtomicUI, displayRespSfxAtomicUI+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , updateItemSlot, markDisplayNeeded, updateItemSlotSide, lookAtMove+  , actorVerbMU, aidVerbMU, itemVerbMU, itemAidVerbMU, msgDuplicateScrap+  , createActorUI, destroyActorUI, spotItem, moveActor, displaceActorUI+  , moveItemUI, quitFactionUI, discover, ppSfxMsg, setLastSlot, strike+#endif   ) where  import Prelude ()@@ -10,59 +17,59 @@ import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES+import           Data.Key (mapWithKeyM_) import qualified Data.Map.Strict as M-import Data.Tuple-import GHC.Exts (inline)+import           Data.Tuple+import           GHC.Exts (inline) import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.CommonM-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.ActorUI-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.FrameM-import Game.LambdaHack.Client.UI.HandleHelperM-import Game.LambdaHack.Client.UI.ItemDescription-import Game.LambdaHack.Client.UI.ItemSlot+import           Game.LambdaHack.Atomic+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.ActorUI+import           Game.LambdaHack.Client.UI.Animation+import           Game.LambdaHack.Client.UI.FrameM+import           Game.LambdaHack.Client.UI.HandleHelperM+import           Game.LambdaHack.Client.UI.ItemDescription+import           Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.Msg-import Game.LambdaHack.Client.UI.MsgM-import Game.LambdaHack.Client.UI.Overlay-import Game.LambdaHack.Client.UI.OverlayM-import Game.LambdaHack.Client.UI.SessionUI-import Game.LambdaHack.Client.UI.Slideshow-import Game.LambdaHack.Client.UI.SlideshowM-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.Slideshow+import           Game.LambdaHack.Client.UI.SlideshowM+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Flavour-import Game.LambdaHack.Common.Item+import qualified Game.LambdaHack.Common.Dice as Dice+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Flavour+import           Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Point-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.ReqFailure+import           Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile+import           Game.LambdaHack.Common.Time import qualified Game.LambdaHack.Content.ItemKind as IK-import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind+import           Game.LambdaHack.Content.ModeKind+import           Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Content.TileKind as TK  -- * RespUpdAtomicUI --- | Visualize atomic actions sent to the client. This is done+-- | Visualize atomic updates sent to the client. This is done -- in the global state after the command is executed and after -- the client state is modified by the command.-displayRespUpdAtomicUI :: MonadClientUI m-                       => Bool -> StateClient -> UpdAtomic -> m ()+displayRespUpdAtomicUI :: MonadClientUI m => Bool -> UpdAtomic -> m () {-# INLINE displayRespUpdAtomicUI #-}-displayRespUpdAtomicUI verbose oldCli cmd = case cmd of+displayRespUpdAtomicUI verbose cmd = case cmd of   -- Create/destroy actors and items.   UpdCreateActor aid body _ -> createActorUI True aid body   UpdDestroyActor aid body _ -> destroyActorUI True aid body@@ -88,7 +95,7 @@             ownerFun <- partActorLeaderFun             let wown = ppContainerWownW ownerFun True c             itemVerbMU iid kit (MU.Text $ makePhrase $ "appear" : wown) c-            mleader <- getsClient _sleader+            mleader <- getsClient sleader             when (Just aid == mleader) $               modifySession $ \sess -> sess {slastSlot}       CEmbed lid _ -> markDisplayNeeded lid@@ -106,48 +113,11 @@     markDisplayNeeded lid   UpdSpotActor aid body _ -> createActorUI False aid body   UpdLoseActor aid body _ -> destroyActorUI False aid body-  UpdSpotItem verbose2 iid _ kit c -> do-    -- This is due to a move, or similar, which will be displayed,-    -- so no extra @markDisplayNeeded@ needed here and in similar places.-    ItemSlots itemSlots _ <- getsSession sslots-    case lookup iid $ map swap $ EM.assocs itemSlots of-      Nothing ->  -- never seen or would have a slot-        case c of-          CActor aid store ->-            -- Most probably an actor putting item in or out of shared stash.-            void $ updateItemSlotSide store aid iid-          CEmbed{} -> return ()-          CFloor lid p -> do-            void $ updateItemSlot CGround Nothing iid-            sxhairOld <- getsSession sxhair-            case sxhairOld of-              TEnemy{} -> return ()  -- probably too important to overwrite-              TPoint TEnemyPos{} _ _ -> return ()-              _ -> do-                -- Don't steal xhair if it's only an item on another level.-                -- For enemies, OTOH, capture xhair to alarm player.-                lidV <- viewedLevelUI-                when (lid == lidV) $ do-                  bag <- getsState $ getFloorBag lid p-                  modifySession $ \sess ->-                    sess {sxhair = TPoint (TItem bag) lidV p}-            itemVerbMU iid kit "be spotted" c-            stopPlayBack-          CTrunk{} -> return ()-      _ -> return ()  -- seen already (has a slot assigned)-    when verbose2 $ case c of-      CActor aid store | store `elem` [CEqp, CInv] -> do-        -- Actor fetching an item from shared stash, most probably.-        bUI <- getsSession $ getActorUI aid-        subject <- partActorLeader aid bUI-        let ownW = ppCStoreWownW False store subject-            verb = MU.Text $ makePhrase $ "be added to" : ownW-        itemVerbMU iid kit verb c-      _ -> return ()+  UpdSpotItem verbose2 iid _ kit c -> spotItem verbose2 iid kit c+  {-   UpdLoseItem False _ _ _ _ -> return ()   -- The message is rather cryptic, so let's disable it until it's decided   -- if anemy inventories should be displayed, etc.-  {-   UpdLoseItem True iid _ kit c@(CActor aid store) | store /= CSha -> do     -- Actor putting an item into shared stash, most probably.     side <- getsClient sside@@ -158,6 +128,9 @@     when (bfid b == side) $ itemVerbMU iid kit verb c   -}   UpdLoseItem{} -> return ()+  UpdSpotItemBag c bag _ ->+    mapWithKeyM_ (\iid kit -> spotItem True iid kit c) bag+  UpdLoseItemBag{} -> return ()   -- Move actors and items.   UpdMoveActor aid source target -> moveActor aid source target   UpdWaitActor aid _ -> when verbose $ aidVerbMU aid "wait"@@ -196,11 +169,9 @@        | otherwise -> do          when (n >= bhp b && bhp b > 0) $            actorVerbMU aid bUI "return from the brink of death"-         mleader <- getsClient _sleader+         mleader <- getsClient sleader          when (Just aid == mleader) $ do-           actorAspect <- getsClient sactorAspect-           let ar = fromMaybe (error $ "" `showFailure` aid)-                              (EM.lookup aid actorAspect)+           ar <- getsState $ getActorAspect aid            -- Regenerating actors never stop gaining HP, so we need to stop            -- reporting it after they reach full HP for the first time.            when (bhp b >= xM (aMaxHP ar) && bhp b - n < xM (aMaxHP ar)) $ do@@ -226,26 +197,26 @@   -- Change faction attributes.   UpdQuitFaction fid _ toSt -> quitFactionUI fid toSt   UpdLeadFaction fid (Just source) (Just target) -> do-    side <- getsClient sside-    when (fid == side) $ do-      fact <- getsState $ (EM.! side) . sfactionD-      lidV <- viewedLevelUI-      when (isAIFact fact) $ markDisplayNeeded lidV-      -- This faction can't run with multiple actors, so this is not-      -- a leader change while running, but rather server changing-      -- their leader, which the player should be alerted to.-      when (noRunWithMulti fact) stopPlayBack-      actorD <- getsState sactorD-      case EM.lookup source actorD of-        Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do-          -- Regardless who the leader is, give proper names here, not 'you'.-          sbUI <- getsSession $ getActorUI source-          tbUI <- getsSession $ getActorUI target-          let subject = partActor tbUI-              object  = partActor sbUI-          msgAdd $ makeSentence [ MU.SubjectVerbSg subject "take command"-                                , "from", object ]-        _ -> return ()+    fact <- getsState $ (EM.! fid) . sfactionD+    lidV <- viewedLevelUI+    when (isAIFact fact) $ markDisplayNeeded lidV+    -- This faction can't run with multiple actors, so this is not+    -- a leader change while running, but rather server changing+    -- their leader, which the player should be alerted to.+    when (noRunWithMulti fact) stopPlayBack+    actorD <- getsState sactorD+    case EM.lookup source actorD of+      Just sb | bhp sb <= 0 -> assert (not $ bproj sb) $ do+        -- Regardless who the leader is, give proper names here, not 'you'.+        sbUI <- getsSession $ getActorUI source+        tbUI <- getsSession $ getActorUI target+        let subject = partActor tbUI+            object  = partActor sbUI+        msgAdd $ makeSentence [ MU.SubjectVerbSg subject "take command"+                              , "from", object ]+      _ -> return ()+    lookAtMove target+  UpdLeadFaction _ Nothing (Just target) -> lookAtMove target   UpdLeadFaction{} -> return ()   UpdDiplFaction fid1 fid2 _ toDipl -> do     name1 <- getsState $ gname . (EM.! fid1) . sfactionD@@ -263,23 +234,41 @@     when (fid == side) $ setFrontAutoYes b   UpdRecordKill{} -> return ()   -- Alter map.-  UpdAlterTile lid _ _ _ -> markDisplayNeeded lid+  UpdAlterTile lid p fromTile toTile -> do+    markDisplayNeeded lid+    Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops+    let feats = TK.tfeature $ okind fromTile+        toAlter feat =+          case feat of+            TK.OpenTo tgroup -> Just tgroup+            TK.CloseTo tgroup -> Just tgroup+            TK.ChangeTo tgroup -> Just tgroup+            _ -> Nothing+        groupsToAlterTo = mapMaybe toAlter feats+        freq = map fst $ filter (\(_, q) -> q > 0) $ TK.tfreq $ okind toTile+    when (null $ intersect freq groupsToAlterTo) $ do+      -- Player notices @fromTile can't be altered into @toTIle@,+      -- which is uncanny, so we produce a message.+      -- This happens when the player missed an earlier search of the tile+      -- performed by another faction.+      let subject = ""  -- a hack, we we don't handle adverbs well+          verb = "turn into"+          msg = makeSentence [ "the", MU.Text $ TK.tname $ okind fromTile+                             , "at position", MU.Text $ tshow p+                             , "suddenly"  -- adverb+                             , MU.SubjectVerbSg subject verb+                             , MU.AW $ MU.Text $ TK.tname $ okind toTile ]+      msgAdd msg   UpdAlterExplorable{} -> return ()-  UpdSearchTile aid p toTile -> do+  UpdSearchTile aid _p toTile -> do     Kind.COps{cotile = cotile@Kind.Ops{okind}} <- getsState scops-    b <- getsState $ getActorBody aid-    lvl <- getLevel $ blid b     subject <- partAidLeader aid-    let t = lvl `at` p-        fromTile = Tile.hideAs cotile toTile-        verb | t == toTile = "confirm"-             | otherwise = "reveal"+    let fromTile = fromJust $ Tile.hideAs cotile toTile         subject2 = MU.Text $ TK.tname $ okind fromTile-        verb2 = "be"         object = MU.Text $ TK.tname $ okind toTile-    let msg = makeSentence [ MU.SubjectVerbSg subject verb+    let msg = makeSentence [ MU.SubjectVerbSg subject "reveal"                            , "that the"-                           , MU.SubjectVerbSg subject2 verb2+                           , MU.SubjectVerbSg subject2 "be"                            , MU.AW object ]     unless (subject2 == object) $ msgAdd msg   UpdHideTile{} -> return ()@@ -292,25 +281,18 @@   UpdTimeItem{} -> return ()   UpdAgeGame{} -> do     sdisplayNeeded <- getsSession sdisplayNeeded-    when sdisplayNeeded $ do-      -- Push the frame depicting the current level to the frame queue.-      -- Only one line of the report is shown, as in animations,-      -- because it may not be our turn, so we can't clear the message-      -- to see what is underneath.-      lidV <- viewedLevelUI-      report <- getReportUI-      let truncRep = [renderReport report]-      frame <- drawOverlay ColorFull False truncRep lidV-      displayFrames lidV [Just frame]+    when sdisplayNeeded pushFrame   UpdUnAgeGame{} -> return ()-  UpdDiscover c iid _ _ -> discover c oldCli iid+  UpdDiscover c iid _ _ -> discover c iid   UpdCover{} -> return ()  -- don't spam when doing undo-  UpdDiscoverKind c iid _ -> discover c oldCli iid+  UpdDiscoverKind{} -> return ()  -- don't spam when server tweaks stuff   UpdCoverKind{} -> return ()  -- don't spam when doing undo-  UpdDiscoverSeed c iid _ -> discover c oldCli iid+  UpdDiscoverSeed{} -> return ()  -- don't spam when server tweaks stuff   UpdCoverSeed{} -> return ()  -- don't spam when doing undo+  UpdDiscoverServer{} -> error "server command leaked to client"+  UpdCoverServer{} -> error "server command leaked to client"   UpdPerception{} -> return ()-  UpdRestart fid _ _ _ _ _ -> do+  UpdRestart fid _ _ _ _ -> do     sstart <- getsSession sstart     when (sstart == 0) resetSessionStart     history <- getsSession shistory@@ -319,9 +301,11 @@       let title = rtitle $ Kind.stdRuleset corule       msgAdd $ "Welcome to" <+> title <> "!"       -- Generate initial history. Only for UI clients.-      sconfig <- getsSession sconfig-      shistory <- defaultHistory $ configHistoryMax sconfig+      sUIOptions <- getsSession sUIOptions+      shistory <- defaultHistory $ uHistoryMax sUIOptions       modifySession $ \sess -> sess {shistory}+    lid <- getArenaUI+    lvl <- getLevel lid     mode <- getGameMode     curChal <- getsClient scurChal     fact <- getsState $ (EM.! fid) . sfactionD@@ -329,7 +313,8 @@           [] -> True           [(_, 1, _)] -> True           _ -> False-    msgAdd $ "New game started in" <+> mname mode <+> "mode." <+> mdesc mode+    msgAdd $ "New game started in" <+> mname mode <+> "mode."+             <+> mdesc mode <+> ldesc lvl              <+> if cwolf curChal && not loneMode                  then "Being a lone wolf, you start without companions."                  else ""@@ -345,8 +330,11 @@     fact <- getsState $ (EM.! fid) . sfactionD     setFrontAutoYes $ isAIFact fact     unless (isAIFact fact) $ do+      lid <- getArenaUI+      lvl <- getLevel lid       mode <- getGameMode-      promptAdd $ "Continuing" <+> mname mode <> "." <+> mdesc mode+      promptAdd $ "Continuing" <+> mname mode <> "."+                  <+> mdesc mode <+> ldesc lvl                   <+> "Are you up for the challenge?"       slides <- reportToSlideshow [K.spaceKM, K.escKM]       km <- getConfirms ColorFull [K.spaceKM, K.escKM] slides@@ -354,10 +342,6 @@   UpdResumeServer{} -> return ()   UpdKillExit{} -> frontendShutdown   UpdWriteSave -> when verbose $ promptAdd "Saving backup."-  UpdMsgAll "SortSlots" -> do  -- hack-    side <- getsClient sside-    sortSlots side Nothing-  UpdMsgAll msg -> msgAdd msg  updateItemSlot :: MonadClientUI m                => CStore -> Maybe ActorId -> ItemId -> m SlotChar@@ -391,8 +375,7 @@ markDisplayNeeded :: MonadClientUI m => LevelId -> m () markDisplayNeeded lid = do   lidV <- viewedLevelUI-  when (lidV == lid) $-     modifySession $ \sess -> sess {sdisplayNeeded = True}+  when (lidV == lid) $ modifySession $ \sess -> sess {sdisplayNeeded = True}  updateItemSlotSide :: MonadClientUI m                    => CStore -> ActorId -> ItemId -> m SlotChar@@ -424,7 +407,6 @@         adjOur = filter our adjacentAssocs     unless (null adjOur) stopPlayBack --- | Sentences such as \"Dog barks loudly.\". actorVerbMU :: MonadClientUI m => ActorId -> ActorUI -> MU.Part -> m () actorVerbMU aid bUI verb = do   subject <- partActorLeader aid bUI@@ -440,7 +422,7 @@ itemVerbMU iid kit@(k, _) verb c = assert (k > 0) $ do   lid <- getsState $ lidFromC c   localTime <- getsState $ getLocalTime lid-  itemToF <- itemToFullClient+  itemToF <- getsState itemToFull   side <- getsClient sside   factionD <- getsState sfactionD   let subject = partItemWs side factionD@@ -464,7 +446,7 @@   case iid `EM.lookup` bag of     Nothing -> error $ "" `showFailure` (aid, verb, iid, cstore)     Just kit@(k, _) -> do-      itemToF <- itemToFullClient+      itemToF <- getsState itemToFull       let lid = blid body       localTime <- getsState $ getLocalTime lid       subject <- partAidLeader aid@@ -488,7 +470,7 @@  msgDuplicateScrap :: MonadClientUI m => m Bool msgDuplicateScrap = do-  report <- getsSession _sreport+  report <- getsSession sreport   history <- getsSession shistory   let (lastMsg, repRest) = lastMsgOfReport report       repLast = lastReportOfHistory history@@ -508,12 +490,14 @@ createActorUI born aid body = do   side <- getsClient sside   fact <- getsState $ (EM.! bfid body) . sfactionD+  globalTime <- getsState stime+  localTime <- getsState $ getLocalTime $ blid body   mbUI <- getsSession $ EM.lookup aid . sactorUI   bUI <- case mbUI of     Just bUI -> return bUI     Nothing -> do       trunk <- getsState $ getItemBody $ btrunk body-      Config{configHeroNames} <- getsSession sconfig+      UIOptions{uHeroNames} <- getsSession sUIOptions       let isBlast = actorTrunkIsBlast trunk           baseColor = flavourToColor $ jflavour trunk           basePronoun | not (bproj body) && fhasGender (gplayer fact) = "he"@@ -525,7 +509,7 @@             if gcolor fact /= Color.BrWhite             then (nameFromNumber (fname $ gplayer fact) k, "he")             else fromMaybe (nameFromNumber (fname $ gplayer fact) k, "he")-                 $ lookup k configHeroNames+                 $ lookup k uHeroNames       (n, bsymbol) <-         if | bproj body -> return (0, if isBlast then jsymbol trunk else '*')            | baseColor /= Color.BrWhite -> return (0, jsymbol trunk)@@ -538,7 +522,6 @@                  n = fromJust $ elemIndex False mhs              return (n, if 0 < n && n < 10 then Char.intToDigit n else '@')       factionD <- getsState sfactionD-      localTime <- getsState $ getLocalTime $ blid body       let (bname, bpronoun) =             if | bproj body ->                  let adj | length (btrajectory body) < 5 = "falling"@@ -558,10 +541,12 @@       modifySession $ \sess ->         sess {sactorUI = EM.insert aid bUI $ sactorUI sess}       return bUI-  let verb = if born-             then MU.Text $ "appear"-                            <+> if bfid body == side then "" else "suddenly"-             else "be spotted"+  let verb = MU.Text $+        if born+        then if globalTime == timeZero+             then "be here"+             else "appear" <+> if bfid body == side then "" else "suddenly"+        else "be spotted"   mapM_ (\(iid, store) -> void $ updateItemSlotSide store aid iid)         (getCarriedIidCStore body)   when (bfid body /= side) $ do@@ -582,7 +567,6 @@   else do     actorVerbMU aid bUI verb     animate (blid body) $ actorX (bpos body)-  lookAtMove aid  destroyActorUI :: MonadClientUI m => Bool -> ActorId -> Actor -> m () destroyActorUI destroy aid b = do@@ -613,7 +597,7 @@       modifySession $ \sess -> sess {sselected = upd $ sselected sess}       when destroy $ do         displayMore ColorBW "Alas!"-        mleader <- getsClient _sleader+        mleader <- getsClient sleader         when (isJust mleader)           -- This is especially handy when the dead actor was a leader           -- on a different level than the new one:@@ -621,6 +605,48 @@     -- If pushed, animate spotting again, to draw attention to pushing.     markDisplayNeeded (blid b) +spotItem :: MonadClientUI m+         => Bool -> ItemId -> ItemQuant -> Container -> m ()+spotItem verbose iid kit c = do+  -- This is due to a move, or similar, which will be displayed,+  -- so no extra @markDisplayNeeded@ needed here and in similar places.+  ItemSlots itemSlots _ <- getsSession sslots+  case lookup iid $ map swap $ EM.assocs itemSlots of+    Nothing ->  -- never seen or would have a slot+      case c of+        CActor aid store ->+          -- Most probably an actor putting item in or out of shared stash.+          void $ updateItemSlotSide store aid iid+        CEmbed{} -> return ()+        CFloor lid p -> do+          void $ updateItemSlot CGround Nothing iid+          sxhairOld <- getsSession sxhair+          case sxhairOld of+            TEnemy{} -> return ()  -- probably too important to overwrite+            TPoint TEnemyPos{} _ _ -> return ()+            _ -> do+              -- Don't steal xhair if it's only an item on another level.+              -- For enemies, OTOH, capture xhair to alarm player.+              lidV <- viewedLevelUI+              when (lid == lidV) $ do+                bag <- getsState $ getFloorBag lid p+                modifySession $ \sess ->+                  sess {sxhair = TPoint (TItem bag) lidV p}+          itemVerbMU iid kit "be spotted" c+          stopPlayBack+        CTrunk{} -> return ()+    _ -> return ()  -- this item or another with the same @iid@+                    -- seen already (has a slot assigned), so old news+  when verbose $ case c of+    CActor aid store | store `elem` [CEqp, CInv, CGround, CSha] -> do+      -- Actor fetching an item from or to shared stash, most probably.+      bUI <- getsSession $ getActorUI aid+      subject <- partActorLeader aid bUI+      let ownW = ppCStoreWownW False store subject+          verb = MU.Text $ makePhrase $ "be added to" : ownW+      itemVerbMU iid kit verb c+    _ -> return ()+ moveActor :: MonadClientUI m => ActorId -> Point -> Point -> m () moveActor aid source target = do   -- If source and target tile distant, assume it's a teleportation@@ -661,7 +687,7 @@   b <- getsState $ getActorBody aid   fact <- getsState $ (EM.! bfid b) . sfactionD   let underAI = isAIFact fact-  mleader <- getsClient _sleader+  mleader <- getsClient sleader   ItemSlots itemSlots _ <- getsSession sslots   case lookup iid $ map swap $ EM.assocs itemSlots of     Just slastSlot -> do@@ -752,7 +778,7 @@             sli <- overlayToSlideshow (lysize + 1) [K.spaceKM, K.escKM] io             return (bag, sli, tot)         localTime <- getsState $ getLocalTime arena-        itemToF <- itemToFullClient+        itemToF <- getsState itemToFull         ItemSlots lSlots _ <- getsSession sslots         let keyOfEKM (Left km) = km             keyOfEKM (Right SlotChar{slotChar}) = [K.mkChar slotChar]@@ -806,15 +832,13 @@         fadeOutOrIn True     _ -> return () -discover :: MonadClientUI m => Container -> StateClient -> ItemId -> m ()-discover c oldCli iid = do-  let StateClient{sdiscoKind=oldDiscoKind, sdiscoAspect=oldDiscoAspect} = oldCli-      cstore = storeFromC c+discover :: MonadClientUI m => Container -> ItemId -> m ()+discover c iid = do+  let cstore = storeFromC c   lid <- getsState $ lidFromC c-  discoKind <- getsClient sdiscoKind-  discoAspect <- getsClient sdiscoAspect+  globalTime <- getsState stime   localTime <- getsState $ getLocalTime lid-  itemToF <- itemToFullClient+  itemToF <- getsState itemToFull   bag <- getsState $ getContainerBag c   side <- getsClient sside   factionD <- getsState sfactionD@@ -839,14 +863,10 @@       namePhrase = MU.Phrase $ [secretName, secretAEText] ++ nameWhere       msg = makeSentence         ["the", MU.SubjectVerbSg namePhrase "turn out to be", knownName]-      jix = jkindIx $ itemBase itemFull-      ik = itemKind $ fromJust $ itemDisco itemFull   -- Compare descriptions of all aspects and effects to determine   -- if the discovery was meaningful to the player.-  unless (isOurOrgan-          || (EM.member jix discoKind == EM.member jix oldDiscoKind-              && (EM.member iid discoAspect == EM.member iid oldDiscoAspect-                  || not (aspectsRandom ik)))) $+  unless (globalTime == timeZero  -- don't spam about initial equipment+          || isOurOrgan) $  -- assume own faction organs known intuitively     msgAdd msg  -- * RespSfxAtomicUI@@ -949,26 +969,36 @@             msgAdd $ makeSentence               [MU.SubjectVerbSg subject verb, MU.Text fidSourceName, "control"]           stopPlayBack-        IK.Impress -> actorVerbMU aid bUI $ "be awestruck"+        IK.Impress -> actorVerbMU aid bUI "be awestruck"         IK.Summon grp p -> do           let verb = if bproj b then "lure" else "summon"-              object = if p == 1-                       then MU.Text $ tshow grp-                       else MU.Ws $ MU.Text $ tshow grp  -- avoid "1 + dl 3"+              object = (if p == 1  -- avoid "2 + 4 dl 3"+                        then MU.AW+                        else MU.Ws) $ MU.Text $ tshow grp           actorVerbMU aid bUI $ MU.Phrase [verb, object]-        IK.Ascend True -> actorVerbMU aid bUI "find a way upstairs"-        IK.Ascend False -> actorVerbMU aid bUI "find a way downstairs"+        IK.Ascend True -> do+          actorVerbMU aid bUI "find a way upstairs"+          (lid, _) <- getsState $ whereTo (blid b) (bpos b) (Just True)+                                  . sdungeon+          lvl <- getLevel lid+          msgAdd $ ldesc lvl+        IK.Ascend False -> do+          actorVerbMU aid bUI "find a way downstairs"+          (lid, _) <- getsState $ whereTo (blid b) (bpos b) (Just False)+                                  . sdungeon+          lvl <- getLevel lid+          msgAdd $ ldesc lvl         IK.Escape{} -> return ()         IK.Paralyze{} -> actorVerbMU aid bUI "be paralyzed"         IK.InsertMove{} -> actorVerbMU aid bUI "act with extreme speed"-        IK.Teleport t | t <= 8 -> actorVerbMU aid bUI "blink"+        IK.Teleport t | Dice.maxDice t <= 9 -> actorVerbMU aid bUI "blink"         IK.Teleport{} -> actorVerbMU aid bUI "teleport"         IK.CreateItem{} -> return ()         IK.DropItem _ _ COrgan _ -> return ()         IK.DropItem{} -> actorVerbMU aid bUI "be stripped"         IK.PolyItem -> do           localTime <- getsState $ getLocalTime $ blid b-          allAssocs <- fullAssocsClient aid [CGround]+          allAssocs <- getsState $ fullAssocs aid [CGround]           case allAssocs of             [] -> return ()  -- invisible items?             (_, ItemFull{..}) : _ -> do@@ -983,7 +1013,7 @@                 [ MU.SubjectVerbSg subject verb                 , "the", secretName, secretAEText, store ]         IK.Identify -> do-          allAssocs <- fullAssocsClient aid [CGround]+          allAssocs <- getsState $ fullAssocs aid [CGround]           case allAssocs of             [] -> return ()  -- invisible items?             (_, ItemFull{..}) : _ -> do@@ -1026,8 +1056,9 @@         IK.Temporary t -> actorVerbMU aid bUI $ MU.Text t         IK.Unique -> error $ "" `showFailure` sfx         IK.Periodic -> error $ "" `showFailure` sfx+        IK.Composite{} -> error $ "" `showFailure` sfx   SfxMsgFid _ sfxMsg -> do-    mleader <- getsClient _sleader+    mleader <- getsClient sleader     case mleader of       Just{} -> return ()  -- will display stuff when leader moves       Nothing -> do@@ -1036,6 +1067,9 @@         recordHistory     msg <- ppSfxMsg sfxMsg     msgAdd msg+  SfxSortSlots -> do+    side <- getsClient sside+    sortSlots side Nothing  ppSfxMsg :: MonadClientUI m => SfxMsg -> m Text ppSfxMsg sfxMsg = case sfxMsg of@@ -1101,8 +1135,7 @@         return $! makeSentence [MU.SubjectVerbSg subject verb]   SfxEscapeImpossible -> return "This faction doesn't want to escape outside."   SfxTransImpossible -> return "Translocation not possible."-  SfxIdentifyNothing store -> return $!-    "Nothing to identify" <+> ppCStoreIn store <> "."+  SfxIdentifyNothing -> return "Nothing to identify."   SfxPurposeNothing store -> return $!     "The purpose of repurpose cannot be availed without an item"     <+> ppCStoreIn store <> "."@@ -1117,18 +1150,18 @@     aidPhrase <- partActorLeader aid bUI     factionD <- getsState sfactionD     localTime <- getsState $ getLocalTime (blid b)-    itemToF <- itemToFullClient+    itemToF <- getsState itemToFull     let itemFull = itemToF iid (1, [])         (_, _, name, stats) =           partItem (bfid b) factionD cstore localTime itemFull         storeOwn = ppCStoreWownW True cstore aidPhrase-        cond = if jsymbol (itemBase itemFull) == '+' then ["condition"] else []+        cond = ["condition" | jsymbol (itemBase itemFull) == '+']     return $! makeSentence $       ["the", name, stats] ++ cond ++ storeOwn ++ ["will now last longer"]  setLastSlot :: MonadClientUI m => ActorId -> ItemId -> CStore -> m () setLastSlot aid iid cstore = do-  mleader <- getsClient _sleader+  mleader <- getsClient sleader   when (Just aid == mleader) $ do     ItemSlots itemSlots _ <- getsSession sslots     case lookup iid $ map swap $ EM.assocs itemSlots of@@ -1138,14 +1171,13 @@ strike :: MonadClientUI m        => Bool -> ActorId -> ActorId -> ItemId -> CStore -> m () strike catch source target iid cstore = assert (source /= target) $ do-  actorAspect <- getsClient sactorAspect   tb <- getsState $ getActorBody target   tbUI <- getsSession $ getActorUI target   sourceSeen <- getsState $ memActor source (blid tb)   (ps, hurtMult) <-    if sourceSeen then do-    hurtMult <- getsState $ armorHurtBonus actorAspect source target-    itemToF <- itemToFullClient+    hurtMult <- getsState $ armorHurtBonus source target+    itemToF <- getsState itemToFull     sb <- getsState $ getActorBody source     sbUI <- getsSession $ getActorUI source     spart <- partActorLeader source sbUI@@ -1168,7 +1200,7 @@           else partItemShortAW side factionD cstore localTime         msg | bhp tb <= 0  -- incapacitated, so doesn't actively block               || hurtMult > 90  -- at most minor armor-              || jdamage (itemBase itemFull) <= 0 = makeSentence $+              || jdamage (itemBase itemFull) == 0 = makeSentence $               [MU.SubjectVerbSg spart verb, tpart]               ++ if bproj sb                  then []

@@ -15,65 +15,63 @@  import Game.LambdaHack.Common.Prelude -import Control.Arrow (first)-import Control.Monad.ST.Strict+import           Control.Monad.ST.Strict import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import Data.Ord+import           Data.Ord import qualified Data.Text as T import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as VM-import Data.Word (Word16)-import GHC.Exts (inline)+import           Data.Word (Word16)+import           GHC.Exts (inline) import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Client.Bfs-import Game.LambdaHack.Client.BfsM-import Game.LambdaHack.Client.CommonM-import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.ActorUI-import Game.LambdaHack.Client.UI.ItemDescription-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.Overlay-import Game.LambdaHack.Client.UI.SessionUI-import Game.LambdaHack.Common.Actor-import Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Client.Bfs+import           Game.LambdaHack.Client.BfsM+import           Game.LambdaHack.Client.CommonM+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.ActorUI+import           Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.UI.ItemDescription+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemStrongest+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Item+import           Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind import qualified Game.LambdaHack.Common.KindOps as KindOps-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.Perception+import           Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray-import Game.LambdaHack.Common.State+import           Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Common.Vector+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ModeKind as MK-import Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace)+import           Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace) import qualified Game.LambdaHack.Content.TileKind as TK  targetDesc :: MonadClientUI m => Maybe Target -> m (Maybe Text, Maybe Text) targetDesc mtarget = do   arena <- getArenaUI   lidV <- viewedLevelUI-  mleader <- getsClient _sleader+  mleader <- getsClient sleader   case mtarget of     Just (TEnemy aid _) -> do       side <- getsClient sside       b <- getsState $ getActorBody aid       bUI <- getsSession $ getActorUI aid-      actorAspect <- getsClient sactorAspect-      let ar = fromMaybe (error $ "" `showFailure` aid)-                         (EM.lookup aid actorAspect)-          percentage = 100 * bhp b `div` xM (max 5 $ aMaxHP ar)+      ar <- getsState $ getActorAspect aid+      let percentage = 100 * bhp b `div` xM (max 5 $ aMaxHP ar)           chs n = "[" <> T.replicate n "*"                       <> T.replicate (4 - n) "_" <> "]"           stars = chs $ fromEnum $ max 0 $ min 4 $ percentage `div` 20@@ -95,7 +93,7 @@               [] -> return $! "exact spot" <+> tshow p               [(iid, kit@(k, _))] -> do                 localTime <- getsState $ getLocalTime lid-                itemToF <- itemToFullClient+                itemToF <- getsState itemToFull                 side <- getsClient sside                 factionD <- getsState sfactionD                 let (_, _, name, stats) =@@ -206,7 +204,7 @@   Level{lxsize, lysize, ltile=PointArray.Array{avector}}     <- getLevel drawnLevelId   totVisible <- totalVisible <$> getPerFid drawnLevelId-  mleader <- getsClient _sleader+  mleader <- getsClient sleader   xhairPosRaw <- xhairToPos   let xhairPos = fromMaybe originPoint xhairPosRaw   s <- getState@@ -224,7 +222,7 @@         | pathGoal == xhairPos -> return tapPath       _ -> getCachePath aid xhairPos) mleader   let lpath = if null bline then []-              else maybe [] (\mp -> case mp of+              else maybe [] (\case                 NoPath -> []                 AndPath {pathList} -> pathList) mpath       xhairHere = find (\(_, m) -> xhairPos == bpos m)@@ -271,7 +269,7 @@   SessionUI{sselected} <- getSession   Level{lxsize, lactor} <- getLevel drawnLevelId   side <- getsClient sside-  mleader <- getsClient _sleader+  mleader <- getsClient sleader   s <- getState   sactorUI <- getsSession sactorUI   let {-# INLINE viewActor #-}@@ -316,7 +314,7 @@   totVisible <- totalVisible <$> getPerFid drawnLevelId   mxhairPos <- xhairToPos   mtgtPos <- do-    mleader <- getsClient _sleader+    mleader <- getsClient sleader     case mleader of       Nothing -> return Nothing       Just leader -> do@@ -365,7 +363,7 @@ drawFrameStatus :: MonadClientUI m => LevelId -> m AttrLine drawFrameStatus drawnLevelId = do   SessionUI{sselected, saimMode, swaitTimes, sitemSel} <- getSession-  mleader <- getsClient _sleader+  mleader <- getsClient sleader   xhairPos <- xhairToPos   tgtPos <- leaderTgtToPos   mbfs <- maybe (return Nothing) (\aid -> Just <$> getCacheBfs aid) mleader@@ -443,7 +441,7 @@               Nothing -> return $! tgtBlurb               Just kit@(k, _) -> do                 localTime <- getsState $ getLocalTime (blid b)-                itemToF <- itemToFullClient+                itemToF <- getsState itemToFull                 factionD <- getsState sfactionD                 let (_, _, name, stats) =                       partItem (bfid b) factionD@@ -465,9 +463,6 @@                <+:> targetStatus  -- | Draw the whole screen: level map and status area.--- Pass at most a single page if overlay of text unchanged--- to the frontends to display separately or overlay over map,--- depending on the frontend. drawBaseFrame :: MonadClientUI m => ColorMode -> LevelId -> m FrameForall drawBaseFrame dm drawnLevelId = do   Level{lxsize, lysize} <- getLevel drawnLevelId@@ -492,7 +487,7 @@ -- level descriptions (currently enforced max). drawArenaStatus :: Bool -> Level -> Int -> AttrLine drawArenaStatus explored-                Level{ldepth=AbsDepth ld, ldesc, lseen, lexplorable}+                Level{ldepth=AbsDepth ld, lname, lseen, lexplorable}                 width =   let seenN = 100 * lseen `div` max 1 lexplorable       seenTxt | explored || seenN >= 100 = "all"@@ -500,20 +495,18 @@       lvlN = T.justifyLeft 2 ' ' (tshow ld)       seenStatus = "[" <> seenTxt <+> "seen]"   in textToAL $ T.justifyLeft width ' '-              $ T.take 29 (lvlN <+> T.justifyLeft 26 ' ' ldesc) <+> seenStatus+              $ T.take 29 (lvlN <+> T.justifyLeft 26 ' ' lname) <+> seenStatus  drawLeaderStatus :: MonadClient m => Int -> m AttrLine drawLeaderStatus waitT = do   let calmHeaderText = "Calm"       hpHeaderText = "HP"-  mleader <- getsClient _sleader+  mleader <- getsClient sleader   case mleader of     Just leader -> do-      actorAspect <- getsClient sactorAspect+      ar <- getsState $ getActorAspect leader       s <- getState-      let ar = fromMaybe (error $ "" `showFailure` leader)-                         (EM.lookup leader actorAspect)-          showTrunc :: Show a => a -> String+      let showTrunc :: Show a => a -> String           showTrunc = (\t -> if length t > 3 then "***" else t) . show           (darkL, bracedL, hpDelta, calmDelta,            ahpS, bhpS, acalmS, bcalmS) =@@ -554,22 +547,22 @@  drawLeaderDamage :: MonadClientUI m => Int -> m AttrLine drawLeaderDamage width = do-  mleader <- getsClient _sleader+  mleader <- getsClient sleader   let addColor = map (Color.attrChar2ToW32 Color.BrCyan)   stats <- case mleader of     Just leader -> do-      allAssocsRaw <- fullAssocsClient leader [CEqp, COrgan]+      allAssocsRaw <- getsState $ fullAssocs leader [CEqp, COrgan]       let allAssocs = filter (isMelee . itemBase . snd) allAssocsRaw       actorSk <- leaderSkillsClientUI-      actorAspect <- getsClient sactorAspect-      strongest <- pickWeaponM Nothing allAssocs actorSk actorAspect leader+      actorAspect <- getsState sactorAspect+      strongest <- pickWeaponM Nothing allAssocs actorSk leader       let damage = case strongest of             [] -> "0"             (_, (_, itemFull)) : _ ->               let tdice = show $ jdamage $ itemBase itemFull                   bonusRaw = aHurtMelee $ actorAspect EM.! leader                   bonus = min 200 $ max (-200) bonusRaw-                  unknownBonus = unknownMelee $ map snd allAssocs+                  unknownBonus = unknownMeleeBonus $ map snd allAssocs                   tbonus = if bonus == 0                            then if unknownBonus then "+?" else ""                            else (if bonus > 0 then "+" else "")@@ -585,7 +578,7 @@ drawSelected :: MonadClientUI m              => LevelId -> Int -> ES.EnumSet ActorId -> m (Int, AttrLine) drawSelected drawnLevelId width selected = do-  mleader <- getsClient _sleader+  mleader <- getsClient sleader   side <- getsClient sside   sactorUI <- getsSession sactorUI   ours <- getsState $ filter (not . bproj . snd)

@@ -1,9 +1,12 @@--- | Description of effects. No operation in this module--- involves state or monad types.+-- | Description of effects. module Game.LambdaHack.Client.UI.EffectDescription-  ( effectToSuffix, featureToSuff, kindAspectToSuffix, affixDice-  , featureToSentence, slotToSentence-  , slotToName, slotToDesc, slotToDecorator, statSlots+  ( effectToSuffix+  , slotToSentence, slotToName, slotToDesc, slotToDecorator, statSlots+  , kindAspectToSuffix, featureToSuff, featureToSentence, affixDice+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , tmodToSuff, affixBonus, wrapInParens, wrapInChevrons+#endif   ) where  import Prelude ()@@ -13,12 +16,12 @@ import qualified Data.Text as T import qualified NLP.Miniutter.English as MU -import Game.LambdaHack.Common.Ability-import Game.LambdaHack.Common.Actor+import           Game.LambdaHack.Common.Ability+import           Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ItemKind+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Time+import           Game.LambdaHack.Content.ItemKind  -- | Suffix to append to a basic content name if the content causes the effect. --@@ -36,7 +39,7 @@     ELabel _ -> ""  -- printed specially     EqpSlot{} -> ""  -- used in @slotToSentence@ instead     Burn d -> wrapInParens (tshow d-                            <+> if d > 1 then "burns" else "burn")+                            <+> if Dice.maxDice d > 1 then "burns" else "burn")     Explode t -> "of" <+> tshow t <+> "explosion"     RefillHP p | p > 0 -> "of healing" <+> wrapInParens (affixBonus p)     RefillHP 0 -> error $ "" `showFailure` effect@@ -68,9 +71,10 @@             Nothing -> tshow dice <+> "moves"             Just p -> makePhrase [MU.CarWs p "move"]       in "of speed surge for" <+> moves-    Teleport dice | dice <= 0 ->+    Teleport dice | Dice.minDice dice <= 0 ->       error $ "" `showFailure` effect-    Teleport dice | dice <= 9 -> "of blinking" <+> wrapInParens (tshow dice)+    Teleport dice | Dice.maxDice dice <= 9 ->+      "of blinking" <+> wrapInParens (tshow dice)     Teleport dice -> "of teleport" <+> wrapInParens (tshow dice)     CreateItem COrgan grp tim ->       let stime = if tim == TimerNone then "" else "for" <+> tshow tim <> ":"@@ -86,7 +90,7 @@           verb = if store == COrgan then "nullify" else "drop"       in "of" <+> verb <+> ntxt <+> tshow grp  -- TMI: <+> ppCStore store     PolyItem -> "of repurpose on the ground"-    Identify -> "of identify on the ground"+    Identify -> "of identify"     Detect radius -> "of detection" <+> wrapInParens (tshow radius)     DetectActor radius -> "of actor detection" <+> wrapInParens (tshow radius)     DetectItem radius -> "of item detection" <+> wrapInParens (tshow radius)@@ -107,6 +111,7 @@     Temporary _ -> ""     Unique -> ""  -- marked by capital letters in name     Periodic -> ""  -- printed specially+    Composite effs -> T.intercalate " and then " $ map effectToSuffix effs  slotToSentence :: EqpSlot -> Text slotToSentence es = case es of

@@ -1,21 +1,49 @@+{-# LANGUAGE RankNTypes #-} -- | Screen frames. module Game.LambdaHack.Client.UI.Frame-  ( SingleFrame(..), Frames+  ( FrameST, FrameForall(..), writeLine+  , SingleFrame(..), Frames   , blankSingleFrame, overlayFrame, overlayFrameWithLines+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , truncateAttrLine+#endif   ) where  import Prelude ()  import Game.LambdaHack.Common.Prelude -import Data.Word (Word32)+import           Control.Monad.ST.Strict+import qualified Data.Vector.Generic as G+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as VM+import           Data.Word -import Game.LambdaHack.Client.UI.Overlay-import Game.LambdaHack.Common.Color-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Common.Point+import           Game.LambdaHack.Client.UI.Overlay+import qualified Game.LambdaHack.Common.Color as Color+import           Game.LambdaHack.Common.Misc+import           Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray +type FrameST s = G.Mutable U.Vector s Word32 -> ST s ()++-- | Efficiently composable representation of an operation+-- on a frame, that is, on a mutable vector. When the composite operation+-- is eventually performed, the vector is frozen to become a 'SingleFrame'.+newtype FrameForall = FrameForall {unFrameForall :: forall s. FrameST s}++-- | Representation of an operation of overwriting a frame with a single line+-- at the given row.+writeLine :: Int -> AttrLine -> FrameForall+{-# INLINE writeLine #-}+writeLine offset l = FrameForall $ \v -> do+  let writeAt _ [] = return ()+      writeAt off (ac32 : rest) = do+        VM.write v off (Color.attrCharW32 ac32)+        writeAt (off + 1) rest+  writeAt offset l+ -- | An overlay that fits on the screen (or is meant to be truncated on display) -- and is padded to fill the whole screen -- and is displayed as a single game screen frame.@@ -23,7 +51,7 @@ -- Note that we don't provide a list of color-highlighed positions separately, -- because overlays need to obscure not only map, but the highlights as well. newtype SingleFrame = SingleFrame-  {singleFrame :: PointArray.GArray Word32 AttrCharW32}+  {singleFrame :: PointArray.GArray Word32 Color.AttrCharW32}   deriving (Eq, Show)  -- | Sequences of screen frames, including delays.@@ -33,11 +61,11 @@ blankSingleFrame =   let lxsize = fst normalLevelBound + 1       lysize = snd normalLevelBound + 4-  in SingleFrame $ PointArray.replicateA lxsize lysize spaceAttrW32+  in SingleFrame $ PointArray.replicateA lxsize lysize Color.spaceAttrW32  -- | Truncate the overlay: for each line, if it's too long, it's truncated -- and if there are too many lines, excess is dropped and warning is appended.-truncateLines :: Bool -> [AttrLine] -> [AttrLine]+truncateLines :: Bool -> Overlay -> Overlay truncateLines onBlank l =   let lxsize = fst normalLevelBound + 1       lysize = snd normalLevelBound + 1@@ -57,24 +85,24 @@ truncateAttrLine w xs lenMax =   case compare w (length xs) of     LT -> let discarded = drop w xs-          in if all (== spaceAttrW32) discarded+          in if all (== Color.spaceAttrW32) discarded              then take w xs-             else take (w - 1) xs ++ [attrChar2ToW32 BrBlack '$']+             else take (w - 1) xs ++ [Color.attrChar2ToW32 Color.BrBlack '$']     EQ -> xs-    GT -> let xsSpace = if null xs || last xs == spaceAttrW32+    GT -> let xsSpace = if null xs || last xs == Color.spaceAttrW32                         then xs-                        else xs ++ [spaceAttrW32]+                        else xs ++ [Color.spaceAttrW32]               whiteN = max (40 - length xsSpace) (1 + lenMax - length xsSpace)-          in xsSpace ++ replicate whiteN spaceAttrW32+          in xsSpace ++ replicate whiteN Color.spaceAttrW32  -- | Overlays either the game map only or the whole empty screen frame. -- We assume the lines of the overlay are not too long nor too many.-overlayFrame :: Overlay -> FrameForall -> FrameForall+overlayFrame :: IntOverlay -> FrameForall -> FrameForall overlayFrame ov ff = FrameForall $ \v -> do   unFrameForall ff v   mapM_ (\(offset, l) -> unFrameForall (writeLine offset l) v) ov -overlayFrameWithLines :: Bool -> [AttrLine] -> FrameForall -> FrameForall+overlayFrameWithLines :: Bool -> Overlay -> FrameForall -> FrameForall overlayFrameWithLines onBlank l msf =   let lxsize = fst normalLevelBound + 1       ov = map (\(y, al) -> (y * lxsize, al))

@@ -1,6 +1,10 @@ -- | A set of Frame monad operations. module Game.LambdaHack.Client.UI.FrameM-  ( drawOverlay, promptGetKey, stopPlayBack, animate, fadeOutOrIn+  ( pushFrame, promptGetKey, stopPlayBack, animate, fadeOutOrIn+#ifdef EXPOSE_INTERNAL+    -- * Internal operations+  , drawOverlay, renderFrames+#endif   ) where  import Prelude ()@@ -9,38 +13,50 @@  import qualified Data.EnumMap.Strict as EM -import Game.LambdaHack.Client.MonadClient-import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Animation-import Game.LambdaHack.Client.UI.Config-import Game.LambdaHack.Client.UI.DrawM-import Game.LambdaHack.Client.UI.Frame+import           Game.LambdaHack.Client.ClientOptions+import           Game.LambdaHack.Client.MonadClient+import           Game.LambdaHack.Client.State+import           Game.LambdaHack.Client.UI.Animation+import           Game.LambdaHack.Client.UI.DrawM+import           Game.LambdaHack.Client.UI.Frame import qualified Game.LambdaHack.Client.UI.Key as K-import Game.LambdaHack.Client.UI.MonadClientUI-import Game.LambdaHack.Client.UI.Msg-import Game.LambdaHack.Client.UI.MsgM-import Game.LambdaHack.Client.UI.Overlay-import Game.LambdaHack.Client.UI.SessionUI-import Game.LambdaHack.Common.ActorState-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Level-import Game.LambdaHack.Common.MonadStateRead-import Game.LambdaHack.Common.State+import           Game.LambdaHack.Client.UI.MonadClientUI+import           Game.LambdaHack.Client.UI.Msg+import           Game.LambdaHack.Client.UI.MsgM+import           Game.LambdaHack.Client.UI.Overlay+import           Game.LambdaHack.Client.UI.SessionUI+import           Game.LambdaHack.Client.UI.UIOptions+import           Game.LambdaHack.Common.ActorState+import           Game.LambdaHack.Common.Faction+import           Game.LambdaHack.Common.Level+import           Game.LambdaHack.Common.MonadStateRead+import           Game.LambdaHack.Common.State  -- | Draw the current level with the overlay on top. -- If the overlay is too long, it's truncated. -- Similarly, for each line of the overlay, if it's too wide, it's truncated. drawOverlay :: MonadClientUI m-            => ColorMode -> Bool -> [AttrLine] -> LevelId -> m FrameForall+            => ColorMode -> Bool -> Overlay -> LevelId -> m FrameForall drawOverlay dm onBlank topTrunc lid = do   mbaseFrame <- if onBlank                 then return $ FrameForall $ \_v -> return ()                 else drawBaseFrame dm lid   return $! overlayFrameWithLines onBlank topTrunc mbaseFrame +-- | Push the frame depicting the current level to the frame queue.+-- Only one line of the report is shown, as in animations,+-- because it may not be our turn, so we can't clear the message+-- to see what is underneath.+pushFrame :: MonadClientUI m => m ()+pushFrame = do+  lidV <- viewedLevelUI+  report <- getReportUI+  let truncRep = [renderReport report]+  frame <- drawOverlay ColorFull False truncRep lidV+  displayFrames lidV [Just frame]+ promptGetKey :: MonadClientUI m-             => ColorMode -> [AttrLine] -> Bool -> [K.KM] -> m K.KM+             => ColorMode -> Overlay -> Bool -> [K.KM] -> m K.KM promptGetKey dm ov onBlank frontKeyKeys = do   lidV <- viewedLevelUI   keyPressed <- anyKeyPressed@@ -51,8 +67,8 @@       frontKeyFrame <- drawOverlay dm onBlank ov lidV       displayFrames lidV [Just frontKeyFrame]       modifySession $ \sess -> sess {slastPlay = kms}-      Config{configRunStopMsgs} <- getsSession sconfig-      when configRunStopMsgs $ promptAdd $ "Voicing '" <> tshow km <> "'."+      UIOptions{uRunStopMsgs} <- getsSession sUIOptions+      when uRunStopMsgs $ promptAdd $ "Voicing '" <> tshow km <> "'."       return km     _ : _ -> do       -- We can't continue playback, so wipe out old slastPlay, srunning, etc.@@ -62,10 +78,14 @@       frontKeyFrame <- drawOverlay dm onBlank ov2 lidV       connFrontendFrontKey frontKeyKeys frontKeyFrame     [] -> do+      -- If we ask for a key, then we don't want to run any more+      -- and we want to avoid changing leader back to initial run leader+      -- at the nearest @stopPlayBack@, etc.+      modifySession $ \sess -> sess {srunning = Nothing}       frontKeyFrame <- drawOverlay dm onBlank ov lidV       connFrontendFrontKey frontKeyKeys frontKeyFrame-  (seqCurrent, seqPrevious, k) <- getsSession slastRecord-  let slastRecord = (km : seqCurrent, seqPrevious, k)+  LastRecord seqCurrent seqPrevious k <- getsSession slastRecord+  let slastRecord = LastRecord (km : seqCurrent) seqPrevious k   modifySession $ \sess -> sess { slastRecord                                 , sdisplayNeeded = False }   return km@@ -74,7 +94,7 @@ stopPlayBack = do   modifySession $ \sess -> sess     { slastPlay = []-    , slastRecord = ([], [], 0)+    , slastRecord = LastRecord [] [] 0         -- Needed to cancel macros that contain apostrophes.     , swaitTimes = - abs (swaitTimes sess)     }@@ -99,7 +119,7 @@   report <- getReportUI   let truncRep = [renderReport report]   basicFrame <- drawOverlay ColorFull False truncRep arena-  snoAnim <- getsClient $ snoAnim . sdebugCli+  snoAnim <- getsClient $ snoAnim . soptions   return $! if fromMaybe False snoAnim             then [Just basicFrame]             else renderAnim basicFrame anim