LambdaHack 0.4.100.0 → 0.4.101.0

raw patch · 123 files changed

+7451/−4918 lines, 123 filesdep ~containersdep ~randomPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: containers, random

API changes (from Hackage documentation)

Files

• CHANGELOG.md +27/−1
• Game/LambdaHack/Atomic.hs +4/−4
• Game/LambdaHack/Atomic/BroadcastAtomicWrite.hs +12/−14
• Game/LambdaHack/Atomic/CmdAtomic.hs +38/−31
• Game/LambdaHack/Atomic/HandleAtomicWrite.hs +67/−48
• Game/LambdaHack/Atomic/MonadAtomic.hs +8/−2
• Game/LambdaHack/Atomic/MonadStateWrite.hs +39/−37
• Game/LambdaHack/Atomic/PosAtomicRead.hs +39/−24
• Game/LambdaHack/Client.hs +4/−36
• Game/LambdaHack/Client/AI.hs +23/−16
• Game/LambdaHack/Client/AI/ConditionClient.hs +168/−46
• Game/LambdaHack/Client/AI/HandleAbilityClient.hs +375/−293
• Game/LambdaHack/Client/AI/PickActorClient.hs +51/−26
• Game/LambdaHack/Client/AI/PickTargetClient.hs +156/−121
• Game/LambdaHack/Client/AI/Preferences.hs +64/−52
• Game/LambdaHack/Client/AI/Strategy.hs +5/−2
• Game/LambdaHack/Client/Bfs.hs +16/−13
• Game/LambdaHack/Client/BfsClient.hs +110/−53
• Game/LambdaHack/Client/CommonClient.hs +86/−66
• Game/LambdaHack/Client/HandleAtomicClient.hs +42/−77
• Game/LambdaHack/Client/HandleResponseClient.hs +2/−4
• Game/LambdaHack/Client/ItemSlot.hs +49/−34
• Game/LambdaHack/Client/Key.hs +54/−17
• Game/LambdaHack/Client/LoopClient.hs +3/−2
• Game/LambdaHack/Client/State.hs +17/−16
• Game/LambdaHack/Client/UI.hs +29/−55
• Game/LambdaHack/Client/UI/Animation.hs +106/−47
• Game/LambdaHack/Client/UI/Config.hs +4/−3
• Game/LambdaHack/Client/UI/Content/KeyKind.hs +15/−0
• Game/LambdaHack/Client/UI/DisplayAtomicClient.hs +284/−195
• Game/LambdaHack/Client/UI/DrawClient.hs +56/−47
• Game/LambdaHack/Client/UI/Frontend.hs +35/−30
• Game/LambdaHack/Client/UI/Frontend/Chosen.hs +5/−5
• Game/LambdaHack/Client/UI/Frontend/Curses.hs +4/−5
• Game/LambdaHack/Client/UI/Frontend/Gtk.hs +83/−46
• Game/LambdaHack/Client/UI/Frontend/Std.hs +4/−5
• Game/LambdaHack/Client/UI/Frontend/Vty.hs +17/−13
• Game/LambdaHack/Client/UI/HandleHumanClient.hs +20/−12
• Game/LambdaHack/Client/UI/HandleHumanGlobalClient.hs +402/−165
• Game/LambdaHack/Client/UI/HandleHumanLocalClient.hs +140/−284
• Game/LambdaHack/Client/UI/HumanCmd.hs +73/−41
• Game/LambdaHack/Client/UI/InventoryClient.hs +1021/−415
• Game/LambdaHack/Client/UI/KeyBindings.hs +64/−49
• Game/LambdaHack/Client/UI/MonadClientUI.hs +65/−48
• Game/LambdaHack/Client/UI/MsgClient.hs +24/−18
• Game/LambdaHack/Client/UI/RunClient.hs +88/−135
• Game/LambdaHack/Client/UI/StartupFrontendClient.hs +7/−5
• Game/LambdaHack/Client/UI/WidgetClient.hs +92/−40
• Game/LambdaHack/Common/Ability.hs +4/−7
• Game/LambdaHack/Common/Actor.hs +75/−59
• Game/LambdaHack/Common/ActorState.hs +135/−46
• Game/LambdaHack/Common/Dice.hs +39/−27
• Game/LambdaHack/Common/EffectDescription.hs +17/−18
• Game/LambdaHack/Common/Faction.hs +6/−26
• Game/LambdaHack/Common/File.hs +1/−1
• Game/LambdaHack/Common/Frequency.hs +26/−20
• Game/LambdaHack/Common/HighScore.hs +52/−47
• Game/LambdaHack/Common/Item.hs +3/−2
• Game/LambdaHack/Common/ItemDescription.hs +76/−44
• Game/LambdaHack/Common/ItemStrongest.hs +20/−38
• Game/LambdaHack/Common/Kind.hs +12/−11
• Game/LambdaHack/Common/Level.hs +4/−3
• Game/LambdaHack/Common/Misc.hs +33/−6
• Game/LambdaHack/Common/MonadStateRead.hs +9/−2
• Game/LambdaHack/Common/Msg.hs +27/−17
• Game/LambdaHack/Common/Point.hs +12/−4
• Game/LambdaHack/Common/PointArray.hs +43/−5
• Game/LambdaHack/Common/Random.hs +4/−4
• Game/LambdaHack/Common/Request.hs +44/−29
• Game/LambdaHack/Common/Save.hs +1/−1
• Game/LambdaHack/Common/State.hs +23/−11
• Game/LambdaHack/Common/Tile.hs +41/−28
• Game/LambdaHack/Common/Time.hs +5/−6
• Game/LambdaHack/Common/Vector.hs +21/−12
• Game/LambdaHack/Content/CaveKind.hs +1/−1
• Game/LambdaHack/Content/ItemKind.hs +55/−51
• Game/LambdaHack/Content/ModeKind.hs +32/−4
• Game/LambdaHack/Content/RuleKind.hs +0/−1
• Game/LambdaHack/Content/TileKind.hs +6/−0
• Game/LambdaHack/SampleImplementation/SampleMonadClient.hs +4/−1
• Game/LambdaHack/SampleImplementation/SampleMonadServer.hs +17/−3
• Game/LambdaHack/Server.hs +8/−47
• Game/LambdaHack/Server/Commandline.hs +4/−0
• Game/LambdaHack/Server/CommonServer.hs +84/−65
• Game/LambdaHack/Server/DebugServer.hs +17/−13
• Game/LambdaHack/Server/DungeonGen.hs +28/−27
• Game/LambdaHack/Server/DungeonGen/AreaRnd.hs +4/−4
• Game/LambdaHack/Server/DungeonGen/Cave.hs +9/−8
• Game/LambdaHack/Server/DungeonGen/Place.hs +19/−16
• Game/LambdaHack/Server/EndServer.hs +14/−16
• Game/LambdaHack/Server/Fov.hs +106/−112
• Game/LambdaHack/Server/Fov/Digital.hs +23/−9
• Game/LambdaHack/Server/HandleEffectServer.hs +258/−192
• Game/LambdaHack/Server/HandleRequestServer.hs +89/−77
• Game/LambdaHack/Server/ItemRev.hs +42/−20
• Game/LambdaHack/Server/ItemServer.hs +71/−29
• Game/LambdaHack/Server/LoopServer.hs +64/−65
• Game/LambdaHack/Server/MonadServer.hs +14/−12
• Game/LambdaHack/Server/PeriodicServer.hs +83/−62
• Game/LambdaHack/Server/ProtocolServer.hs +2/−1
• Game/LambdaHack/Server/StartServer.hs +62/−47
• Game/LambdaHack/Server/State.hs +43/−4
• GameDefinition/Client/UI/Content/KeyKind.hs +83/−57
• GameDefinition/Content/CaveKind.hs +67/−20
• GameDefinition/Content/ItemKind.hs +276/−159
• GameDefinition/Content/ItemKindActor.hs +240/−97
• GameDefinition/Content/ItemKindBlast.hs +70/−35
• GameDefinition/Content/ItemKindOrgan.hs +177/−25
• GameDefinition/Content/ItemKindTemporary.hs +11/−11
• GameDefinition/Content/ModeKind.hs +139/−43
• GameDefinition/Content/ModeKindPlayer.hs +62/−18
• GameDefinition/Content/PlaceKind.hs +22/−2
• GameDefinition/Content/RuleKind.hs +1/−2
• GameDefinition/Content/TileKind.hs +5/−5
• GameDefinition/PLAYING.md +122/−148
• GameDefinition/TieKnot.hs +26/−14
• GameDefinition/config.ui.default +37/−37
• GameDefinition/scores binary
• LICENSE +2/−2
• LambdaHack.cabal +24/−16
• Makefile +73/−143
• README.md +24/−24
• test/test.hs +1/−1

@@ -1,4 +1,30 @@-## [v0.4.100.0, aka 'The last thaw'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.99.0..v0.4.100.0)+## [v0.4.101.0, aka 'Officially fun'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.100.0...v0.4.101.0)++- the game is now officially fun to play+- introduce unique boss monsters and unique artifact items+- add animals that heal the player+- let AI gang up, attempt stealth and react to player aggressiveness+- spawn actors fast and close to the enemy+- spawn actors less and less often on a given level, but with growing depth+- prefer weapons with effects, if recharged+- make the bracing melee bonus additive, not multiplicative+- let explosions buffet actors around+- make braced actors immune to translocation effects+- use mouse for movement, actor selection, aiming+- don't run straight with selected actors, but go-to cross-hair with them+- speed up default frame rate, slot down projectiles visually+- rework item manipulation UI+- you can pick up many items at once and it costs only one turn+- allow actors to apply and project from the shared stash+- reverse messages shown in player diary+- display actor organs and stats+- split highscore tables wrt game modes+- move score calculation formula to content+- don't keep the default/example config file commented out; was misleading+- I was naughty again and changed v0.5.0.0 of LambdaHack content API slightly+  one last time++## [v0.4.100.0, aka 'The last thaw'](https://github.com/LambdaHack/LambdaHack/compare/v0.4.99.0...v0.4.100.0)  - unexpectedly thaw and freeze again v0.5.0.0 of LambdaHack content API - unexpectedly implement timeouts and temporary effects easily without FRP

@@ -1,14 +1,14 @@--- | Atomic game state transformations. TODO: haddocks.+-- | Atomic game state transformations. -- -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Atomic-  ( -- * Re-exported from MonadAtomic+  ( -- * Re-exported from "Game.LambdaHack.Atomic.MonadAtomic"     MonadAtomic(..)   , broadcastUpdAtomic, broadcastSfxAtomic-    -- * Re-exported from CmdAtomic+    -- * Re-exported from "Game.LambdaHack.Atomic.CmdAtomic"   , CmdAtomic(..), UpdAtomic(..), SfxAtomic(..), HitAtomic(..)-    -- * Re-exported from PosAtomicRead+    -- * Re-exported from "Game.LambdaHack.Atomic.PosAtomicRead"   , PosAtomic(..), posUpdAtomic, posSfxAtomic, seenAtomicCli, generalMoveItem   ) where 

@@ -37,7 +37,7 @@ handleCmdAtomicServer :: forall m. MonadStateWrite m                       => PosAtomic -> CmdAtomic -> m () handleCmdAtomicServer posAtomic atomic =-  when (seenAtomicSer posAtomic) $ do+  when (seenAtomicSer posAtomic) $ --    storeUndo atomic     handleCmdAtomic atomic @@ -69,15 +69,14 @@         psBroken <- mapM posSfxAtomic atomicBroken         return (ps, False, map SfxAtomic atomicBroken, psBroken)   let atomicPsBroken = zip atomicBroken psBroken-  -- TODO: assert also that the sum of psBroken is equal to ps-  -- TODO: with deep equality these assertions can be expensive. Optimize.-  assert (case ps of-            PosSight{} -> True-            PosFidAndSight{} -> True-            PosFidAndSer (Just _) _ -> True-            _ -> not resets-                 && (null atomicBroken-                     || atomicBroken == [atomic])) skip+  -- TODO: assert also that the sum of psBroken is equal to ps;+  -- with deep equality these assertions can be expensive; optimize.+  let !_A = assert (case ps of+                      PosSight{} -> True+                      PosFidAndSight{} -> True+                      PosFidAndSer (Just _) _ -> True+                      _ -> not resets+                   `blame` (ps, resets)) ()   -- Perform the action on the server.   handleCmdAtomicServer ps atomic   -- Update lights in the dungeon. This is lazy, may not be needed or partially.@@ -85,7 +84,7 @@   -- Send some actions to the clients, one faction at a time.   let sendUI fid cmdUI =         when (fhasUI $ gplayer $ factionD EM.! fid) $ doSendUpdateUI fid cmdUI-      sendAI fid cmdAI = doSendUpdateAI fid cmdAI+      sendAI = doSendUpdateAI       sendA fid cmd = do         sendUI fid $ RespUpdAtomicUI cmd         sendAI fid $ RespUpdAtomicAI cmd@@ -126,12 +125,11 @@                 let remember = atomicRemember lid inPer sOld                     seenNew = seenAtomicCli False fid perNew                     seenOld = seenAtomicCli False fid perOld-                -- TODO: these assertions are probably expensive                 psRem <- mapM posUpdAtomic remember                 -- Verify that we remember only currently seen things.-                assert (allB seenNew psRem) skip+                let !_A = assert (allB seenNew psRem) ()                 -- Verify that we remember only new things.-                assert (allB (not . seenOld) psRem) skip+                let !_A = assert (allB (not . seenOld) psRem) ()                 mapM_ (sendA fid) remember               anySend lid fid perOld perNew         else anySend lid fid perOld perOld

@@ -17,6 +17,7 @@   , undoUpdAtomic, undoSfxAtomic, undoCmdAtomic   ) where +import Control.Applicative import Data.Binary import Data.Int (Int64) import GHC.Generics (Generic)@@ -24,7 +25,6 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind@@ -37,18 +37,23 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ItemKind (ItemKind)-import Game.LambdaHack.Content.ModeKind+import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Content.TileKind as TK +-- | Abstract syntax of atomic commands, that is, atomic game state+-- transformations. data CmdAtomic =-    UpdAtomic !UpdAtomic-  | SfxAtomic !SfxAtomic+    UpdAtomic !UpdAtomic  -- ^ atomic updates+  | SfxAtomic !SfxAtomic  -- ^ atomic special effects   deriving (Show, Eq, Generic)  instance Binary CmdAtomic --- | Abstract syntax of atomic commands.+-- | Abstract syntax of atomic updates, that is, atomic commands+-- that really change the state. Most of them are an encoding of a game+-- state diff, though they also carry some intentional hints+-- that help clients determine whether and how to communicate them to players. data UpdAtomic =   -- Create/destroy actors and items.     UpdCreateActor !ActorId !Actor ![(ItemId, Item)]@@ -68,7 +73,7 @@   | UpdAgeActor !ActorId !(Delta Time)   | UpdRefillHP !ActorId !Int64   | UpdRefillCalm !ActorId !Int64-  | UpdOldFidActor !ActorId !FactionId !FactionId+  | UpdFidImpressedActor !ActorId !FactionId !FactionId   | UpdTrajectory !ActorId !(Maybe ([Vector], Speed)) !(Maybe ([Vector], Speed))   | UpdColorActor !ActorId !Color.Color !Color.Color   -- Change faction attributes.@@ -92,15 +97,14 @@   -- Assorted.   | UpdTimeItem !ItemId !Container !ItemTimer !ItemTimer   | UpdAgeGame !(Delta Time) ![LevelId]-  | UpdDiscover !LevelId !Point !ItemId !(Kind.Id ItemKind) !ItemSeed-  | UpdCover !LevelId !Point !ItemId !(Kind.Id ItemKind) !ItemSeed-  | UpdDiscoverKind !LevelId !Point !ItemId !(Kind.Id ItemKind)-  | UpdCoverKind !LevelId !Point !ItemId !(Kind.Id ItemKind)-  | UpdDiscoverSeed !LevelId !Point !ItemId !ItemSeed-  | UpdCoverSeed !LevelId !Point !ItemId !ItemSeed+  | UpdDiscover !Container !ItemId !(Kind.Id ItemKind) !ItemSeed+  | UpdCover !Container !ItemId !(Kind.Id ItemKind) !ItemSeed+  | UpdDiscoverKind !Container !ItemId !(Kind.Id ItemKind)+  | UpdCoverKind !Container !ItemId !(Kind.Id ItemKind)+  | UpdDiscoverSeed !Container !ItemId !ItemSeed+  | UpdCoverSeed !Container !ItemId !ItemSeed   | UpdPerception !LevelId !Perception !Perception-  | UpdRestart-      !FactionId !DiscoveryKind !FactionPers !State !DebugModeCli !(GroupName ModeKind)+  | UpdRestart !FactionId !DiscoveryKind !FactionPers !State !DebugModeCli   | UpdRestartServer !State   | UpdResume !FactionId !FactionPers   | UpdResumeServer !State@@ -112,17 +116,18 @@  instance Binary UpdAtomic --- | Abstract syntax of atomic special effects.+-- | Abstract syntax of atomic special effects, that is, atomic commands+-- that only display special effects and don't change the state. data SfxAtomic =-    SfxStrike !ActorId !ActorId !ItemId !HitAtomic-  | SfxRecoil !ActorId !ActorId !ItemId !HitAtomic+    SfxStrike !ActorId !ActorId !ItemId !CStore !HitAtomic+  | SfxRecoil !ActorId !ActorId !ItemId !CStore !HitAtomic   | SfxProject !ActorId !ItemId !CStore   | SfxCatch !ActorId !ItemId !CStore-  | SfxActivate !ActorId !ItemId !CStore+  | SfxApply !ActorId !ItemId !CStore   | SfxCheck !ActorId !ItemId !CStore   | SfxTrigger !ActorId !Point !TK.Feature   | SfxShun !ActorId !Point !TK.Feature-  | SfxEffect !FactionId !ActorId !(IK.Effect)+  | SfxEffect !FactionId !ActorId !IK.Effect   | SfxMsgFid !FactionId !Msg   | SfxMsgAll !Msg   | SfxActorStart !ActorId@@ -130,6 +135,7 @@  instance Binary SfxAtomic +-- | Determine if a strike special effect should depict a block of an attack. data HitAtomic = HitClear | HitBlock !Int   deriving (Show, Eq, Generic) @@ -152,7 +158,8 @@   UpdAgeActor aid delta -> Just $ UpdAgeActor aid (timeDeltaReverse delta)   UpdRefillHP aid n -> Just $ UpdRefillHP aid (-n)   UpdRefillCalm aid n -> Just $ UpdRefillCalm aid (-n)-  UpdOldFidActor aid fromFid toFid -> Just $ UpdOldFidActor aid toFid fromFid+  UpdFidImpressedActor aid fromFid toFid ->+    Just $ UpdFidImpressedActor aid toFid fromFid   UpdTrajectory aid fromT toT -> Just $ UpdTrajectory aid toT fromT   UpdColorActor aid fromCol toCol -> Just $ UpdColorActor aid toCol fromCol   UpdQuitFaction fid mb fromSt toSt -> Just $ UpdQuitFaction fid mb toSt fromSt@@ -175,12 +182,12 @@   UpdLoseSmell lid sms -> Just $ UpdSpotSmell lid sms   UpdTimeItem iid c fromIt toIt -> Just $ UpdTimeItem iid c toIt fromIt   UpdAgeGame delta lids -> Just $ UpdAgeGame (timeDeltaReverse delta) lids-  UpdDiscover lid p iid ik seed -> Just $ UpdCover lid p iid ik seed-  UpdCover lid p iid ik seed -> Just $ UpdDiscover lid p iid ik seed-  UpdDiscoverKind lid p iid ik -> Just $ UpdCoverKind lid p iid ik-  UpdCoverKind lid p iid ik -> Just $ UpdDiscoverKind lid p iid ik-  UpdDiscoverSeed lid p iid seed -> Just $ UpdCoverSeed lid p iid seed-  UpdCoverSeed lid p iid seed -> Just $ UpdDiscoverSeed lid p iid seed+  UpdDiscover c iid ik seed -> Just $ UpdCover c iid ik seed+  UpdCover c iid ik seed -> Just $ UpdDiscover c iid ik seed+  UpdDiscoverKind c iid ik -> Just $ UpdCoverKind c iid ik+  UpdCoverKind c iid ik -> Just $ UpdDiscoverKind c iid ik+  UpdDiscoverSeed c iid seed -> Just $ UpdCoverSeed c iid seed+  UpdCoverSeed c iid seed -> Just $ UpdDiscoverSeed c iid seed   UpdPerception lid outPer inPer -> Just $ UpdPerception lid inPer outPer   UpdRestart{} -> Just cmd  -- here history ends; change direction   UpdRestartServer{} -> Just cmd  -- here history ends; change direction@@ -193,12 +200,12 @@  undoSfxAtomic :: SfxAtomic -> SfxAtomic undoSfxAtomic cmd = case cmd of-  SfxStrike source target iid b -> SfxRecoil source target iid b-  SfxRecoil source target iid b -> SfxStrike source target iid b+  SfxStrike source target iid cstore b -> SfxRecoil source target iid cstore b+  SfxRecoil source target iid cstore b -> SfxStrike source target iid cstore b   SfxProject aid iid cstore -> SfxCatch aid iid cstore   SfxCatch aid iid cstore -> SfxProject aid iid cstore-  SfxActivate aid iid cstore -> SfxCheck aid iid cstore-  SfxCheck aid iid cstore -> SfxActivate aid iid cstore+  SfxApply aid iid cstore -> SfxCheck aid iid cstore+  SfxCheck aid iid cstore -> SfxApply aid iid cstore   SfxTrigger aid p feat -> SfxShun aid p feat   SfxShun aid p feat -> SfxTrigger aid p feat   SfxEffect{} -> cmd  -- not ideal?@@ -207,5 +214,5 @@   SfxActorStart{} -> cmd  undoCmdAtomic :: CmdAtomic -> Maybe CmdAtomic-undoCmdAtomic (UpdAtomic cmd) = fmap UpdAtomic $ undoUpdAtomic cmd+undoCmdAtomic (UpdAtomic cmd) = UpdAtomic <$> undoUpdAtomic cmd undoCmdAtomic (SfxAtomic sfx) = Just $ SfxAtomic $ undoSfxAtomic sfx

@@ -60,7 +60,8 @@   UpdAgeActor aid t -> updAgeActor aid t   UpdRefillHP aid n -> updRefillHP aid n   UpdRefillCalm aid n -> updRefillCalm aid n-  UpdOldFidActor aid fromFid toFid -> updOldFidActor aid fromFid toFid+  UpdFidImpressedActor aid fromFid toFid ->+    updFidImpressedActor aid fromFid toFid   UpdTrajectory aid fromT toT -> updTrajectory aid fromT toT   UpdColorActor aid fromCol toCol -> updColorActor aid fromCol toCol   UpdQuitFaction fid mbody fromSt toSt -> updQuitFaction fid mbody fromSt toSt@@ -89,8 +90,8 @@   UpdDiscoverSeed{} -> return ()   UpdCoverSeed{} -> return ()   UpdPerception _ outPer inPer ->-    assert (not (nullPer outPer && nullPer inPer)) skip-  UpdRestart _ _ _ s _ _ -> updRestart s+    assert (not (nullPer outPer && nullPer inPer)) (return ())+  UpdRestart _ _ _ s _ -> updRestart s   UpdRestartServer s -> updRestartServer s   UpdResume{} -> return ()   UpdResumeServer s -> updResumeServer s@@ -146,8 +147,8 @@   -- that do not appear anywhere else, for simplicity and speed.   itemD <- getsState sitemD   let match (iid, item) = itemsMatch (itemD EM.! iid) item-  assert (allB match ais `blame` "destroyed actor items not found"-                         `twith` (aid, body, ais, itemD)) skip+  let !_A = assert (allB match ais `blame` "destroyed actor items not found"+                    `twith` (aid, body, ais, itemD)) ()   -- Remove actor from @sactorD@.   let f Nothing = assert `failure` "actor already removed" `twith` (aid, body)       f (Just b) = assert (b == body `blame` "inconsistent destroyed actor body"@@ -175,34 +176,35 @@   modifyState $ updateItemD $ EM.insertWith f iid item   insertItemContainer iid kit c --- TODO: verify kit -- | Destroy some copies (possibly not all) of an item. updDestroyItem :: MonadStateWrite m                => ItemId -> Item -> ItemQuant -> Container -> m ()-updDestroyItem iid item (k, _) c = assert (k > 0) $ do+updDestroyItem iid item kit@(k, _) c = assert (k > 0) $ do   -- Do not remove the item from @sitemD@ nor from @sitemRev@,   -- It's incredibly costly and not noticeable for the player.   -- However, assert the item is registered in @sitemD@.   itemD <- getsState sitemD-  assert ((case iid `EM.lookup` itemD of-             Nothing -> False-             Just item0 -> itemsMatch item0 item)-           `blame` "item already removed"-           `twith` (iid, item, itemD)) skip-  deleteItemContainer iid k c+  let !_A = assert ((case iid `EM.lookup` itemD of+                        Nothing -> False+                        Just item0 -> itemsMatch item0 item)+                    `blame` "item already removed"+                    `twith` (iid, item, itemD)) ()+  deleteItemContainer iid kit c  updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m () updMoveActor aid fromP toP = assert (fromP /= toP) $ do   b <- getsState $ getActorBody aid-  assert (fromP == bpos b `blame` "unexpected moved actor position"-                          `twith` (aid, fromP, toP, bpos b, b)) skip+  let !_A = assert (fromP == bpos b+                    `blame` "unexpected moved actor position"+                    `twith` (aid, fromP, toP, bpos b, b)) ()   updateActor aid $ \body -> body {bpos = toP, boldpos = fromP}  updWaitActor :: MonadStateWrite m => ActorId -> Bool -> m () updWaitActor aid toWait = do   b <- getsState $ getActorBody aid-  assert (toWait /= bwait b `blame` "unexpected waited actor time"-                            `twith` (aid, toWait, bwait b, b)) skip+  let !_A = assert (toWait /= bwait b+                    `blame` "unexpected waited actor time"+                    `twith` (aid, toWait, bwait b, b)) ()   updateActor aid $ \body -> body {bwait = toWait}  updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m ()@@ -220,17 +222,31 @@   case iid `EM.lookup` bag of     Nothing -> assert `failure` (iid, k, aid, c1, c2)     Just (_, it) -> do-      deleteItemActor iid k aid c1+      deleteItemActor iid (k, take k it) aid c1       insertItemActor iid (k, take k it) aid c2 --- TODO: optimize (a single call to updatePrio is enough)+-- This is equaivalent to (but much cheaper than) updDestroyActor+-- followed by updCreateActor. updAgeActor :: MonadStateWrite m => ActorId -> Delta Time -> m () updAgeActor aid delta = assert (delta /= Delta timeZero) $ do   body <- getsState $ getActorBody aid-  ais <- getsState $ getCarriedAssocs body-  updDestroyActor aid body ais   let newBody = body {btime = timeShift (btime body) delta}-  updCreateActor aid newBody ais+      -- Remove actor from @sprio@ at old time.+      rmPrio Nothing = assert `failure` "actor already removed"+                              `twith` (aid, body)+      rmPrio (Just l) = assert (aid `elem` l `blame` "actor already removed"+                                             `twith` (aid, body, l))+                        $ let l2 = delete aid l+                          in if null l2 then Nothing else Just l2+      -- Add actor to @sprio@ at new time.+      addPrio Nothing = Just [aid]+      addPrio (Just l) = assert (aid `notElem` l `blame` "actor already added"+                                                 `twith` (aid, body, l))+                         $ Just $ aid : l+      updPrio = EM.alter addPrio (btime newBody) . EM.alter rmPrio (btime body)+  updateLevel (blid body) $ updatePrio updPrio+  -- Modify actor body in @sactorD@.+  modifyState $ updateActorD $ EM.adjust (const newBody) aid  updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m () updRefillHP aid n =@@ -254,11 +270,11 @@                         else oldD {resCurrentTurn = resCurrentTurn oldD + n}       } -updOldFidActor :: MonadStateWrite m => ActorId -> FactionId -> FactionId -> m ()-updOldFidActor aid fromFid toFid = assert (fromFid /= toFid) $ do+updFidImpressedActor :: MonadStateWrite m => ActorId -> FactionId -> FactionId -> m ()+updFidImpressedActor aid fromFid toFid = assert (fromFid /= toFid) $   updateActor aid $ \b ->-    assert (boldfid b == fromFid `blame` (aid, fromFid, toFid, b))-    $ b {boldfid = toFid}+    assert (bfidImpressed b == fromFid `blame` (aid, fromFid, toFid, b))+    $ b {bfidImpressed = toFid}  updTrajectory :: MonadStateWrite m               => ActorId@@ -267,27 +283,30 @@               -> m () updTrajectory aid fromT toT = assert (fromT /= toT) $ do   body <- getsState $ getActorBody aid-  assert (fromT == btrajectory body `blame` "unexpected actor trajectory"-                                    `twith` (aid, fromT, toT, body)) skip+  let !_A = assert (fromT == btrajectory body+                    `blame` "unexpected actor trajectory"+                    `twith` (aid, fromT, toT, body)) ()   updateActor aid $ \b -> b {btrajectory = toT}  updColorActor :: MonadStateWrite m               => ActorId -> Color.Color -> Color.Color -> m () updColorActor aid fromCol toCol = assert (fromCol /= toCol) $ do   body <- getsState $ getActorBody aid-  assert (fromCol == bcolor body `blame` "unexpected actor color"-                                 `twith` (aid, fromCol, toCol, body)) skip+  let !_A = assert (fromCol == bcolor body+                    `blame` "unexpected actor color"+                    `twith` (aid, fromCol, toCol, body)) ()   updateActor aid $ \b -> b {bcolor = toCol}  updQuitFaction :: MonadStateWrite m                => FactionId -> Maybe Actor -> Maybe Status -> Maybe Status                -> m () updQuitFaction fid mbody fromSt toSt = do-  assert (fromSt /= toSt `blame` (fid, mbody, fromSt, toSt)) skip-  assert (maybe True ((fid ==) . bfid) mbody) skip+  let !_A = assert (fromSt /= toSt `blame` (fid, mbody, fromSt, toSt)) ()+  let !_A = assert (maybe True ((fid ==) . bfid) mbody) ()   fact <- getsState $ (EM.! fid) . sfactionD-  assert (fromSt == gquit fact `blame` "unexpected actor quit status"-                               `twith` (fid, fromSt, toSt, fact)) skip+  let !_A = assert (fromSt == gquit fact+                    `blame` "unexpected actor quit status"+                    `twith` (fid, fromSt, toSt, fact)) ()   let adj fa = fa {gquit = toSt}   updateFaction fid adj @@ -299,14 +318,14 @@                -> m () updLeadFaction fid source target = assert (source /= target) $ do   fact <- getsState $ (EM.! fid) . sfactionD-  assert (fleaderMode (gplayer fact) /= LeaderNull) skip+  let !_A = assert (fleaderMode (gplayer fact) /= LeaderNull) ()     -- @PosNone@ ensures this   mtb <- getsState $ \s -> flip getActorBody s . fst <$> target-  assert (maybe True (not . bproj) mtb-          `blame` (fid, source, target, mtb, fact)) skip-  assert (source == gleader fact-          `blame` "unexpected actor leader"-          `twith` (fid, source, target, mtb, fact)) skip+  let !_A = assert (maybe True (not . bproj) mtb+                    `blame` (fid, source, target, mtb, fact)) ()+  let !_A = assert (source == gleader fact+                    `blame` "unexpected actor leader"+                    `twith` (fid, source, target, mtb, fact)) ()   let adj fa = fa {gleader = target}   updateFaction fid adj @@ -316,10 +335,10 @@   assert (fid1 /= fid2 && fromDipl /= toDipl) $ do     fact1 <- getsState $ (EM.! fid1) . sfactionD     fact2 <- getsState $ (EM.! fid2) . sfactionD-    assert (fromDipl == EM.findWithDefault Unknown fid2 (gdipl fact1)-            && fromDipl == EM.findWithDefault Unknown fid1 (gdipl fact2)-            `blame` "unexpected actor diplomacy status"-            `twith` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) skip+    let !_A = assert (fromDipl == EM.findWithDefault Unknown fid2 (gdipl fact1)+                      && fromDipl == EM.findWithDefault Unknown fid1 (gdipl fact2)+                      `blame` "unexpected actor diplomacy status"+                      `twith` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) ()     let adj fid fact = fact {gdipl = EM.insert fid toDipl (gdipl fact)}     updateFaction fid1 (adj fid2)     updateFaction fid2 (adj fid1)@@ -343,12 +362,12 @@ updRecordKill :: MonadStateWrite m => ActorId -> Kind.Id ItemKind -> Int -> m () updRecordKill aid ikind k = do   b <- getsState $ getActorBody aid-  assert (not (bproj b) `blame` (aid, b)) skip+  let !_A = assert (not (bproj b) `blame` (aid, b))   let alterKind mn = let n = fromMaybe 0 mn + k                      in if n == 0 then Nothing else Just n       adjFact fact = fact {gvictims = EM.alter alterKind ikind                                       $ gvictims fact}-  updateFaction (bfid b) adjFact+  updateFaction (bfidOriginal b) adjFact  -- | Alter an attribute (actually, the only, the defining attribute) -- of a visible tile. This is similar to e.g., @UpdTrajectory@.@@ -458,8 +477,8 @@   bag <- getsState $ getCBag c   case iid `EM.lookup` bag of     Just (k, it) -> do-      assert (fromIt == it `blame` (k, it, iid, c, fromIt, toIt)) skip-      deleteItemContainer iid k c+      let !_A = assert (fromIt == it `blame` (k, it, iid, c, fromIt, toIt)) ()+      deleteItemContainer iid (k, fromIt) c       insertItemContainer iid (k, toIt) c     Nothing -> assert `failure` (bag, iid, c, fromIt, toIt) 

@@ -1,4 +1,4 @@--- | Atomic monads.+-- | Atomic monads for handling atomic game state transformations. module Game.LambdaHack.Atomic.MonadAtomic   ( MonadAtomic(..)   , broadcastUpdAtomic,  broadcastSfxAtomic@@ -7,23 +7,29 @@ import Data.Key (mapWithKeyM_)  import Game.LambdaHack.Atomic.CmdAtomic-import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State +-- | The monad for executing atomic game state transformations. class MonadStateRead m => MonadAtomic m where+  -- | Execute an arbitrary atomic game state transformation.   execAtomic    :: CmdAtomic -> m ()+  -- | Execute an atomic command that really changes the state.   execUpdAtomic :: UpdAtomic -> m ()   execUpdAtomic = execAtomic . UpdAtomic+  -- | Execute an atomic command that only displays special effects.   execSfxAtomic :: SfxAtomic -> m ()   execSfxAtomic = execAtomic . SfxAtomic +-- | Create and broadcast a set of atomic updates, one for each client. broadcastUpdAtomic :: MonadAtomic m                    => (FactionId -> UpdAtomic) -> m () broadcastUpdAtomic fcmd = do   factionD <- getsState sfactionD   mapWithKeyM_ (\fid _ -> execUpdAtomic $ fcmd fid) factionD +-- | Create and broadcast a set of atomic special effects, one for each client. broadcastSfxAtomic :: MonadAtomic m                    => (FactionId -> SfxAtomic) -> m () broadcastSfxAtomic fcmd = do

@@ -124,71 +124,73 @@   updateFaction fid $ \fact -> fact {gsha = upd (gsha fact)}  deleteItemContainer :: MonadStateWrite m-                    => ItemId -> Int -> Container -> m ()-deleteItemContainer iid k c = case c of-  CFloor lid pos -> deleteItemFloor iid k lid pos-  CEmbed lid pos -> deleteItemEmbed iid k lid pos-  CActor aid store -> deleteItemActor iid k aid store-  CTrunk{} -> return ()+                    => ItemId -> ItemQuant -> Container -> m ()+deleteItemContainer iid kit c = case c of+  CFloor lid pos -> deleteItemFloor iid kit lid pos+  CEmbed lid pos -> deleteItemEmbed iid kit lid pos+  CActor aid store -> deleteItemActor iid kit aid store+  CTrunk{} -> assert `failure` c  deleteItemFloor :: MonadStateWrite m-                => ItemId -> Int -> LevelId -> Point -> m ()-deleteItemFloor iid k lid pos =+                => ItemId -> ItemQuant -> LevelId -> Point -> m ()+deleteItemFloor iid kit lid pos =   let rmFromFloor (Just bag) =-        let nbag = rmFromBag k iid bag+        let nbag = rmFromBag kit iid bag         in if EM.null nbag then Nothing else Just nbag       rmFromFloor Nothing = assert `failure` "item already removed"-                                   `twith` (iid, k, lid, pos)+                                   `twith` (iid, kit, lid, pos)   in updateLevel lid $ updateFloor $ EM.alter rmFromFloor pos  deleteItemEmbed :: MonadStateWrite m-                => ItemId -> Int -> LevelId -> Point -> m ()-deleteItemEmbed iid k lid pos =+                => ItemId -> ItemQuant -> LevelId -> Point -> m ()+deleteItemEmbed iid kit lid pos =   let rmFromFloor (Just bag) =-        let nbag = rmFromBag k iid bag+        let nbag = rmFromBag kit iid bag         in if EM.null nbag then Nothing else Just nbag       rmFromFloor Nothing = assert `failure` "item already removed"-                                   `twith` (iid, k, lid, pos)+                                   `twith` (iid, kit, lid, pos)   in updateLevel lid $ updateEmbed $ EM.alter rmFromFloor pos  deleteItemActor :: MonadStateWrite m-                => ItemId -> Int -> ActorId -> CStore -> m ()-deleteItemActor iid k aid cstore = case cstore of+                => ItemId -> ItemQuant -> ActorId -> CStore -> m ()+deleteItemActor iid kit aid cstore = case cstore of   CGround -> do     b <- getsState $ getActorBody aid-    deleteItemFloor iid k (blid b) (bpos b)-  COrgan -> deleteItemBody iid k aid-  CEqp -> deleteItemEqp iid k aid-  CInv -> deleteItemInv iid k aid+    deleteItemFloor iid kit (blid b) (bpos b)+  COrgan -> deleteItemBody iid kit aid+  CEqp -> deleteItemEqp iid kit aid+  CInv -> deleteItemInv iid kit aid   CSha -> do     b <- getsState $ getActorBody aid-    deleteItemSha iid k (bfid b)+    deleteItemSha iid kit (bfid b) -deleteItemBody :: MonadStateWrite m => ItemId -> Int -> ActorId -> m ()-deleteItemBody iid k aid = do-  updateActor aid $ \b -> b {borgan = rmFromBag k iid (borgan b) }+deleteItemBody :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()+deleteItemBody iid kit aid =+  updateActor aid $ \b -> b {borgan = rmFromBag kit iid (borgan b) } -deleteItemEqp :: MonadStateWrite m => ItemId -> Int -> ActorId -> m ()-deleteItemEqp iid k aid = do-  updateActor aid $ \b -> b {beqp = rmFromBag k iid (beqp b)}+deleteItemEqp :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()+deleteItemEqp iid kit aid =+  updateActor aid $ \b -> b {beqp = rmFromBag kit iid (beqp b)} -deleteItemInv :: MonadStateWrite m => ItemId -> Int -> ActorId -> m ()-deleteItemInv iid k aid = do-  updateActor aid $ \b -> b {binv = rmFromBag k iid (binv b)}+deleteItemInv :: MonadStateWrite m => ItemId -> ItemQuant -> ActorId -> m ()+deleteItemInv iid kit aid =+  updateActor aid $ \b -> b {binv = rmFromBag kit iid (binv b)} -deleteItemSha :: MonadStateWrite m => ItemId -> Int -> FactionId -> m ()-deleteItemSha iid k fid = do-  updateFaction fid $ \fact -> fact {gsha = rmFromBag k iid (gsha fact)}+deleteItemSha :: MonadStateWrite m => ItemId -> ItemQuant -> FactionId -> m ()+deleteItemSha iid kit fid =+  updateFaction fid $ \fact -> fact {gsha = rmFromBag kit iid (gsha fact)}  -- Removing the part of the kit from the front of the list, -- so that @DestroyItem kit (CreateItem kit x) == x@.-rmFromBag :: Int -> ItemId -> ItemBag -> ItemBag-rmFromBag k iid bag =+rmFromBag :: ItemQuant -> ItemId -> ItemBag -> ItemBag+rmFromBag kit@(k, rmIt) iid bag =   let rfb Nothing = assert `failure` "rm from empty slot" `twith` (k, iid, bag)       rfb (Just (n, it)) =         case compare n k of           LT -> assert `failure` "rm more than there is"-                       `twith` (n, k, iid, bag)+                       `twith` (n, kit, iid, bag)           EQ -> Nothing-          GT -> Just (n - k, drop k it)+          GT -> assert (rmIt == take k it+                        `blame` (rmIt, take k it, n, kit, iid, bag))+                $ Just (n - k, drop k it)   in EM.alter rfb iid bag

@@ -16,7 +16,6 @@ import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind@@ -28,13 +27,15 @@ import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile+import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind  -- All functions here that take an atomic action are executed -- in the state just before the action is executed. --- | The type representing visibility of actions to factions,--- based on the position of the action, etc.+-- | The type representing visibility of atomic commands to factions,+-- based on the position of the command, etc. Note that the server+-- sees and smells all positions. data PosAtomic =     PosSight !LevelId ![Point]  -- ^ whomever sees all the positions, notices   | PosFidAndSight ![FactionId] !LevelId ![Point]@@ -47,11 +48,18 @@   | PosNone                     -- ^ never broadcasted, but sent manually   deriving (Show, Eq) --- | Produce the positions where the action takes place.--- The goal of the mechanics: client should not get significantly--- more information by looking at the atomic commands he is able to see--- than by looking at the state changes they enact. E.g., @UpdDisplaceActor@--- in a black room, with one actor carrying a 0-radius light would not be+-- | Produce the positions where the atomic update takes place.+--+-- The goal of the mechanics is to ensure the commands don't carry+-- significantly more information than their corresponding state diffs would.+-- In other words, the atomic commands involving the positions seen by a client+-- should convey similar information as the client would get by directly+-- observing the changes the commands enact on the visible portion of server+-- game state. The client is then free to change its copy of game state+-- accordingly or not --- it only partially reflects reality anyway.+--+-- E.g., @UpdDisplaceActor@ in a black room,+-- with one actor carrying a 0-radius light would not be -- distinguishable by looking at the state (or the screen) from @UpdMoveActor@ -- of the illuminated actor, hence such @UpdDisplaceActor@ should not be -- observable, but @UpdMoveActor@ should be (or the former should be perceived@@ -99,7 +107,7 @@   UpdAgeActor aid _ -> singleAid aid   UpdRefillHP aid _ -> singleAid aid   UpdRefillCalm aid _ -> singleAid aid-  UpdOldFidActor aid _ _ -> singleAid aid+  UpdFidImpressedActor aid _ _ -> singleAid aid   UpdTrajectory aid _ _ -> singleAid aid   UpdColorActor aid _ _ -> singleAid aid   UpdQuitFaction{} -> return PosAll@@ -133,14 +141,14 @@     return $! PosSmell lid ps   UpdTimeItem _ c _ _ -> singleContainer c   UpdAgeGame _ _ -> return PosAll-  UpdDiscover lid p _ _ _ -> return $! PosSight lid [p]-  UpdCover lid p _ _ _ -> return $! PosSight lid [p]-  UpdDiscoverKind lid p _ _ -> return $! PosSight lid [p]-  UpdCoverKind lid p _ _ -> return $! PosSight lid [p]-  UpdDiscoverSeed lid p _ _ -> return $! PosSight lid [p]-  UpdCoverSeed lid p _ _ -> return $! PosSight lid [p]+  UpdDiscover c _ _ _ -> singleContainer c+  UpdCover c _ _ _ -> singleContainer c+  UpdDiscoverKind c _ _ -> singleContainer c+  UpdCoverKind c _ _ -> singleContainer c+  UpdDiscoverSeed c _ _ -> singleContainer c+  UpdCoverSeed c _ _ -> singleContainer c   UpdPerception{} -> return PosNone-  UpdRestart fid _ _ _ _ _ -> return $! PosFid fid+  UpdRestart fid _ _ _ _ -> return $! PosFid fid   UpdRestartServer _ -> return PosSer   UpdResume fid _ -> return $! PosFid fid   UpdResumeServer _ -> return PosSer@@ -152,18 +160,22 @@ -- | Produce the positions where the atomic special effect takes place. posSfxAtomic :: MonadStateRead m => SfxAtomic -> m PosAtomic posSfxAtomic cmd = case cmd of-  SfxStrike source target _ _ -> do+  SfxStrike _ _ _ CSha _ ->  -- shared stash is private+    return PosNone  -- TODO: PosSerAndFidIfSight; but probably never used+  SfxStrike source target _ _ _ -> do     (slid, sp) <- posOfAid source     (tlid, tp) <- posOfAid target     return $! assert (slid == tlid) $ PosSight slid [sp, tp]-  SfxRecoil source target _ _ -> do+  SfxRecoil _ _ _ CSha _ ->  -- shared stash is private+    return PosNone  -- TODO: PosSerAndFidIfSight; but probably never used+  SfxRecoil source target _ _ _ -> do     (slid, sp) <- posOfAid source     (tlid, tp) <- posOfAid target     return $! assert (slid == tlid) $ PosSight slid [sp, tp]-  SfxProject aid _ _ -> singleAid aid-  SfxCatch aid _ _ -> singleAid aid-  SfxActivate aid _ _ -> singleAid aid-  SfxCheck aid _ _ -> singleAid aid+  SfxProject aid _ cstore -> singleContainer $ CActor aid cstore+  SfxCatch aid _ cstore -> singleContainer $ CActor aid cstore+  SfxApply aid _ cstore -> singleContainer $ CActor aid cstore+  SfxCheck aid _ cstore -> singleContainer $ CActor aid cstore   SfxTrigger aid p _ -> do     (lid, pa) <- posOfAid aid     return $! PosSight lid [pa, p]@@ -273,7 +285,7 @@ -- | Decompose an atomic special effect. breakSfxAtomic :: MonadStateRead m => SfxAtomic -> m [SfxAtomic] breakSfxAtomic cmd = case cmd of-  SfxStrike source target _ _ -> do+  SfxStrike source target _ _ _ -> do     -- Hack: make a fight detectable even if one of combatants not visible.     sb <- getsState $ getActorBody source     return $! [ SfxEffect (bfid sb) source (IK.RefillCalm (-1))@@ -302,6 +314,8 @@                                 , MU.AW $ MU.Phrase $ distant ++ [sound] ]   return $! hear <$> msound +-- | Given the client, it's perception and an atomic command, determine+-- if the client notices the command. seenAtomicCli :: Bool -> FactionId -> Perception -> PosAtomic -> Bool seenAtomicCli knowEvents fid per posAtomic =   case posAtomic of@@ -322,10 +336,11 @@     PosNone -> False     _ -> True +-- | Generate the atomic updates that jointly perform a given item move. generalMoveItem :: MonadStateRead m                 => ItemId -> Int -> Container -> Container                 -> m [UpdAtomic]-generalMoveItem iid k c1 c2 = do+generalMoveItem iid k c1 c2 =   case (c1, c2) of     (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2 ->       return [UpdMoveItem iid k aid1 cstore1 cstore2]

@@ -4,43 +4,11 @@ -- See -- <https://github.com/LambdaHack/LambdaHack/wiki/Client-server-architecture>. module Game.LambdaHack.Client-  ( exeFrontend+  ( -- * Re-exported from "Game.LambdaHack.Client.LoopClient"+    loopAI, loopUI+    -- * Re-exported from "Game.LambdaHack.Client.UI"+  , srtFrontend   ) where -import Game.LambdaHack.Atomic import Game.LambdaHack.Client.LoopClient-import Game.LambdaHack.Client.ProtocolClient-import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI-import Game.LambdaHack.Common.ClientOptions-import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Kind as Kind-import Game.LambdaHack.Common.Request-import Game.LambdaHack.Common.Response-import Game.LambdaHack.Common.State---- | Wire together game content, the main loop of game clients,--- the main game loop assigned to this frontend (possibly containing--- the server loop, if the whole game runs in one process),--- UI config and the definitions of game commands.-exeFrontend :: ( MonadAtomic m, MonadClientUI m-               , MonadClientReadResponse ResponseUI m-               , MonadClientWriteRequest RequestUI m-               , MonadAtomic n-               , MonadClientReadResponse ResponseAI n-               , MonadClientWriteRequest RequestAI n )-            => (m () -> SessionUI -> State -> StateClient-                -> chanServerUI-                -> IO ())-            -> (n () -> SessionUI -> State -> StateClient-                -> chanServerAI-                -> IO ())-            -> KeyKind -> Kind.COps -> DebugModeCli-            -> ((FactionId -> chanServerUI -> IO ())-               -> (FactionId -> chanServerAI -> IO ())-               -> IO ())-            -> IO ()-exeFrontend executorUI executorAI copsClient cops sdebugCli exeServer =-  srtFrontend (executorUI . loopUI)-              (executorAI . loopAI)-              copsClient cops sdebugCli exeServer

@@ -2,9 +2,9 @@ -- | Ways for the client to use AI to produce server requests, based on -- the client's view of the game state. module Game.LambdaHack.Client.AI-  ( -- * Public API-    queryAI, pongAI+  ( queryAI, pongAI #ifdef EXPOSE_INTERNAL+    -- * Internal operations   , refreshTarget, pickAction #endif   ) where@@ -51,16 +51,20 @@ pongAI :: MonadClient m => m RequestAI pongAI = return ReqAIPong +-- | Verify and possibly change the target of an actor. This function both+-- updates the target in the client state and returns the new target explicitly. refreshTarget :: MonadClient m-              => ActorId -> (ActorId, Actor)-              -> m (Maybe ((ActorId, Actor), (Target, PathEtc)))-refreshTarget oldLeader (aid, body) = do+              => (ActorId, Actor)  -- ^ the actor to refresh+              -> m (Maybe (Target, PathEtc))+refreshTarget (aid, body) = do   side <- getsClient sside-  assert (bfid body == side `blame` "AI tries to move an enemy actor"-                            `twith` (aid, body, side)) skip-  assert (not (bproj body) `blame` "AI gets to manually move its projectiles"-                           `twith` (aid, body, side)) skip-  stratTarget <- targetStrategy oldLeader aid+  let !_A = assert (bfid body == side+                    `blame` "AI tries to move an enemy actor"+                    `twith` (aid, body, side)) ()+  let !_A = assert (not (bproj body)+                    `blame` "AI gets to manually move its projectiles"+                    `twith` (aid, body, side)) ()+  stratTarget <- targetStrategy aid   tgtMPath <-     if nullStrategy stratTarget then       -- No sensible target; wipe out the old one.@@ -79,18 +83,21 @@           <> "\nHandleAI target:"   <+> tshow tgtMPath --  trace _debug skip   modifyClient $ \cli ->-    cli {stargetD = EM.alter (const $ tgtMPath) aid (stargetD cli)}+    cli {stargetD = EM.alter (const tgtMPath) aid (stargetD cli)}   return $! case tgtMPath of-    Just (tgt, Just pathEtc) -> Just ((aid, body), (tgt, pathEtc))+    Just (tgt, Just pathEtc) -> Just (tgt, pathEtc)     _ -> Nothing +-- | Pick an action the actor will perfrom this turn. pickAction :: MonadClient m => (ActorId, Actor) -> m RequestAnyAbility pickAction (aid, body) = do   side <- getsClient sside-  assert (bfid body == side `blame` "AI tries to move enemy actor"-                            `twith` (aid, bfid body, side)) skip-  assert (not (bproj body) `blame` "AI gets to manually move its projectiles"-                           `twith` (aid, bfid body, side)) skip+  let !_A = assert (bfid body == side+                    `blame` "AI tries to move enemy actor"+                    `twith` (aid, bfid body, side)) ()+  let !_A = assert (not (bproj body)+                    `blame` "AI gets to manually move its projectiles"+                    `twith` (aid, bfid body, side)) ()   stratAction <- actionStrategy aid   -- Run the AI: chose an action from those given by the AI strategy.   rndToAction $ frequency $ bestVariant stratAction

@@ -3,19 +3,24 @@ module Game.LambdaHack.Client.AI.ConditionClient   ( condTgtEnemyPresentM   , condTgtEnemyRememberedM+  , condTgtEnemyAdjFriendM+  , condTgtNonmovingM   , condAnyFoeAdjM   , condHpTooLowM   , condOnTriggerableM   , condBlocksFriendsM   , condFloorWeaponM   , condNoEqpWeaponM+  , condEnoughGearM   , condCanProjectM   , condNotCalmEnoughM   , condDesirableFloorItemM   , condMeleeBadM   , condLightBetraysM   , benAvailableItems+  , hinders   , benGroundItems+  , desirableItem   , threatDistList   , fleeList   ) where@@ -47,8 +52,10 @@ import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile+import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK+import Game.LambdaHack.Content.ModeKind  -- | Require that the target enemy is visible by the party. condTgtEnemyPresentM :: MonadClient m => ActorId -> m Bool@@ -67,6 +74,31 @@     Just (TEnemyPos _ lid _ permit) | lid == blid b -> not permit     _ -> False +-- | Require that the target enemy is adjacent to at least one friend.+condTgtEnemyAdjFriendM :: MonadClient m => ActorId -> m Bool+condTgtEnemyAdjFriendM aid = do+  btarget <- getsClient $ getTarget aid+  case btarget of+    Just (TEnemy enemy _) -> do+      be <- getsState $ getActorBody enemy+      b <- getsState $ getActorBody aid+      fact <- getsState $ (EM.! bfid b) . sfactionD+      let friendlyFid fid = fid == bfid b || isAllied fact fid+      friends <- getsState $ actorRegularList friendlyFid (blid b)+      return $ any (adjacent (bpos be) . bpos) friends  -- keep it lazy+    _ -> return False++-- | Check if the target is nonmoving.+condTgtNonmovingM :: MonadClient m => ActorId -> m Bool+condTgtNonmovingM aid = do+  btarget <- getsClient $ getTarget aid+  case btarget of+    Just (TEnemy enemy _) -> do+      activeItems <- activeItemsClient enemy+      let actorMaxSkE = sumSkills activeItems+      return $! EM.findWithDefault 0 Ability.AbMove actorMaxSkE <= 0+    _ -> return False+ -- | Require that any non-dying foe is adjacent. condAnyFoeAdjM :: MonadStateRead m => ActorId -> m Bool condAnyFoeAdjM aid = do@@ -102,7 +134,9 @@   allAtWar <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)   let strongActor (aid2, b2) = do         activeItems <- activeItemsClient aid2-        return $! not $ hpTooLow b2 activeItems+        let actorMaxSkE = sumSkills activeItems+            nonmoving = EM.findWithDefault 0 Ability.AbMove actorMaxSkE <= 0+        return $! not $ (hpTooLow b2 activeItems || nonmoving)   allThreats <- filterM strongActor allAtWar   let addDist (aid2, b2) = (chessDist (bpos b) (bpos b2), (aid2, b2))   return $ sortBy (comparing fst) $ map addDist allThreats@@ -119,28 +153,37 @@           _ -> False   return $ any blocked ours  -- keep it lazy --- | Require the actor stands over a weapon.+-- | Require the actor stands over a weapon that would be auto-equipped. condFloorWeaponM :: MonadClient m => ActorId -> m Bool condFloorWeaponM aid = do   floorAssocs <- fullAssocsClient aid [CGround]-  -- We do consider OFF weapons, because e.g., enemies might have turned-  -- them off or they can be wrong for other party members, but are OK for us.-  let lootIsWeapon =-        not $ null $ strongestSlot IK.EqpSlotWeapon floorAssocs-  return $ lootIsWeapon  -- keep it lazy+  let lootIsWeapon = any (isMeleeEqp . snd) floorAssocs+  return lootIsWeapon  -- keep it lazy  -- | Check whether the actor has no weapon in equipment. condNoEqpWeaponM :: MonadClient m => ActorId -> m Bool condNoEqpWeaponM aid = do   allAssocs <- fullAssocsClient aid [CEqp]-  -- We do not consider OFF weapons, because they apparently are not good.-  return $ null $ strongestSlot IK.EqpSlotWeapon allAssocs+  return $ all (not . isMelee . snd) allAssocs  -- keep it lazy++-- | Check whether the actor has enough gear to go look for enemies.+condEnoughGearM :: MonadClient m => ActorId -> m Bool+condEnoughGearM aid = do+  eqpAssocs <- fullAssocsClient aid [CEqp]+  invAssocs <- fullAssocsClient aid [CInv]+  return $ any (isMelee . snd) eqpAssocs+           || length (eqpAssocs ++ invAssocs) >= 5     -- keep it lazy  -- | Require that the actor can project any items.-condCanProjectM :: MonadClient m => ActorId -> m Bool-condCanProjectM aid = do-  actorSk <- actorSkillsClient aid+condCanProjectM :: MonadClient m => Bool -> ActorId -> m Bool+condCanProjectM maxSkills aid = do+  actorSk <- if maxSkills+             then do+               activeItems <- activeItemsClient aid+               return $! sumSkills activeItems+             else+               actorSkillsClient aid   let skill = EM.findWithDefault 0 Ability.AbProject actorSk       q _ itemFull b activeItems =         either (const False) id@@ -164,12 +207,20 @@   b <- getsState $ getActorBody aid   activeItems <- activeItemsClient aid   fact <- getsState $ (EM.! bfid b) . sfactionD+  condAnyFoeAdj <- condAnyFoeAdjM aid+  condLightBetrays <- condLightBetraysM aid+  condTgtEnemyPresent <- condTgtEnemyPresentM aid+  condNotCalmEnough <- condNotCalmEnoughM aid   let ben cstore bag =         [ ((benefit, (k, cstore)), (iid, itemFull))         | (iid, kit@(k, _)) <- EM.assocs bag         , let itemFull = itemToF iid kit-        , let benefit = totalUsefulness cops b activeItems fact itemFull-        , permitted (fst <$> benefit) itemFull b activeItems ]+              benefit = totalUsefulness cops b activeItems fact itemFull+              hind = hinders condAnyFoeAdj condLightBetrays+                             condTgtEnemyPresent condNotCalmEnough+                             b activeItems itemFull+        , permitted (fst <$> benefit) itemFull b activeItems+          && (cstore /= CEqp || hind) ]       benCStore cs = do         bag <- getsState $ getActorBag aid cs         return $! ben cs bag@@ -177,6 +228,37 @@   return $ concat perBag     -- keep it lazy +-- TODO: also take into account dynamic lights *not* wielded by the actor+hinders :: Bool -> Bool -> Bool -> Bool -> Actor -> [ItemFull] -> ItemFull+        -> Bool+hinders condAnyFoeAdj condLightBetrays condTgtEnemyPresent+        condNotCalmEnough  -- perhaps enemies don't have projectiles+        body activeItems itemFull =+  let itemLit = isJust $ strengthFromEqpSlot IK.EqpSlotAddLight itemFull+  in -- Fast actors want to hide in darkness to ambush opponents and want+     -- to hit hard for the short span they get to survive melee.+     bspeed body activeItems > speedNormal+     && (condNotCalmEnough && itemLit+         || 0 > fromMaybe 0 (strengthFromEqpSlot IK.EqpSlotAddHurtMelee+                                                 itemFull)+         || 0 > fromMaybe 0 (strengthFromEqpSlot IK.EqpSlotAddHurtRanged+                                                 itemFull))+     -- In the presence of enemies (seen, or unseen but distressing)+     -- actors want to hide in the dark.+     || let heavilyDistressed =  -- actor hit by a proj or similarly distressed+              deltaSerious (bcalmDelta body)+        in condNotCalmEnough+           && (heavilyDistressed || condTgtEnemyPresent)+           && condLightBetrays && not condAnyFoeAdj+           && itemLit+  -- TODO:+  -- teach AI to turn shields OFF (or stash) when ganging up on an enemy+  -- (friends close, only one enemy close)+  -- and turning on afterwards (AI plays for time, especially spawners+  -- so shields are preferable by default;+  -- also, turning on when no friends and enemies close is too late,+  -- AI should flee or fire at such times, not muck around with eqp)+ -- | Require the actor is not calm enough. condNotCalmEnoughM :: MonadClient m => ActorId -> m Bool condNotCalmEnoughM aid = do@@ -199,35 +281,73 @@ benGroundItems aid = do   b <- getsState $ getActorBody aid   canEscape <- factionCanEscape (bfid b)-  let -- A hack to prevent monsters from picking up treasure.-      preciousWithoutSlot item =-        IK.Precious `elem` jfeature item  -- risk from treasure hunters-        && isNothing (strengthEqpSlot item)  -- unlikely to be useful-      desirableItem use ItemFull{itemBase} _ _-        | canEscape = use /= Just 0-                      || IK.Precious `elem` jfeature itemBase-        | otherwise = use /= Just 0-                      && not (isNothing use  -- needs resources to id-                              && preciousWithoutSlot itemBase)-  benAvailableItems aid desirableItem [CGround]+  benAvailableItems aid (\use itemFull _ _ ->+                           desirableItem canEscape use itemFull) [CGround] +desirableItem :: Bool -> Maybe Int -> ItemFull -> Bool+desirableItem canEsc use itemFull =+  let item = itemBase itemFull+      freq = case itemDisco itemFull of+        Nothing -> []+        Just ItemDisco{itemKind} -> IK.ifreq itemKind+  in if canEsc+     then use /= Just 0+          || IK.Precious `elem` jfeature item+     else+       -- A hack to prevent monsters from picking up unidentified treasure.+       let preciousWithoutSlot =+             IK.Precious `elem` jfeature item  -- risk from treasure hunters+             && isNothing (strengthEqpSlot item)  -- unlikely to be useful+       in use /= Just 0+          && not (isNothing use  -- needs resources to id+                  && preciousWithoutSlot)+          -- TODO: terrible hack for the identified healing gems and normal+          -- gems identified with a scroll+          && maybe True (<= 0) (lookup "gem" freq)+ -- | Require the actor is in a bad position to melee or can't melee at all. condMeleeBadM :: MonadClient m => ActorId -> m Bool condMeleeBadM aid = do   b <- getsState $ getActorBody aid+  btarget <- getsClient $ getTarget aid+  mtgtPos <- aidTgtToPos aid (blid b) btarget+  condTgtEnemyPresent <- condTgtEnemyPresentM aid+  condTgtEnemyRemembered <- condTgtEnemyRememberedM aid   fact <- getsState $ (EM.! bfid b) . sfactionD-  condNoUsableWeapon <- null <$> pickWeaponClient aid aid-  let friendlyFid fid = fid == bfid b || isAllied fact fid+  activeItems <- activeItemsClient aid+  let condNoUsableWeapon = all (not . isMelee) activeItems+      friendlyFid fid = fid == bfid b || isAllied fact fid   friends <- getsState $ actorRegularAssocs friendlyFid (blid b)-  let closeEnough b2 = let dist = chessDist (bpos b) (bpos b2)-                       in dist < 3 && dist > 0+  friendlyFacts <-+    getsState $ map snd . filter (friendlyFid . fst) . EM.assocs . sfactionD+  Level{lactorFreq} <- getLevel $ blid b+  let freqNames = map fst lactorFreq+      factNames = map (fgroup . gplayer) friendlyFacts+      spawnerOnLvl = any (`elem` freqNames) factNames+      closeEnough b2 = let dist = chessDist (bpos b) (bpos b2)+                       in dist > 0 && (dist <= 2 || approaching b2)+      -- 3 is the condThreatAtHand distance that AI keeps when alone.+      approaching = case mtgtPos of+        Just tgtPos | condTgtEnemyPresent || condTgtEnemyRemembered ->+          \b1 -> chessDist (bpos b1) tgtPos <= 3+        _ -> const False       closeFriends = filter (closeEnough . snd) friends       strongActor (aid2, b2) = do-        activeItems <- activeItemsClient aid2-        return $! not $ hpTooLow b2 activeItems+        activeItems2 <- activeItemsClient aid2+        let condUsableWeapon2 = any isMelee activeItems2+            actorMaxSk2 = sumSkills activeItems2+            canMelee2 = EM.findWithDefault 0 Ability.AbMelee actorMaxSk2 > 0+            hpGood = not $ hpTooLow b2 activeItems2+        return $! hpGood && condUsableWeapon2 && canMelee2   strongCloseFriends <- filterM strongActor closeFriends-  let noFriendlyHelp = length closeFriends < 3 && null strongCloseFriends+  let noFriendlyHelp = length closeFriends < 3+                       && null strongCloseFriends+                       && (length friends > 1  -- solo fighters aggresive+                           || spawnerOnLvl)+                       && not (hpHuge b)  -- uniques, etc., aggresive+  let actorMaxSk = sumSkills activeItems   return $ condNoUsableWeapon+           || EM.findWithDefault 0 Ability.AbMelee actorMaxSk <= 0            || noFriendlyHelp  -- still not getting friends' help     -- no $!; keep it lazy @@ -238,16 +358,18 @@   b <- getsState $ getActorBody aid   eqpItems <- map snd <$> fullAssocsClient aid [CEqp]   let actorEqpShines = sumSlotNoFilter IK.EqpSlotAddLight eqpItems > 0-  aInAmbient<- getsState $ actorInAmbient b+  aInAmbient <- getsState $ actorInAmbient b   return $! not aInAmbient     -- tile is dark, so actor could hide             && actorEqpShines  -- but actor betrayed by his equipped light  -- | Produce a list of acceptable adjacent points to flee to.-fleeList :: MonadClient m => Bool -> ActorId -> m [(Int, Point)]-fleeList panic aid = do+fleeList :: MonadClient m => ActorId -> m ([(Int, Point)], [(Int, Point)])+fleeList aid = do   cops <- getsState scops   mtgtMPath <- getsClient $ EM.lookup aid . stargetD   let tgtPath = case mtgtMPath of  -- prefer fleeing along the path to target+        Just (TEnemy{}, _) -> []  -- don't flee towards an enemy+        Just (TEnemyPos{}, _) -> []         Just (_, Just (_ : path, _)) -> path         _ -> []   b <- getsState $ getActorBody aid@@ -261,15 +383,15 @@              | otherwise = minimum $ map (chessDist p) posFoes       dVic = map (dist &&& id) myVic       -- Flee, if possible. Access required.-      accVic = filter (accessibleHere . snd) $ dVic+      accVic = filter (accessibleHere . snd) dVic       gtVic = filter ((> dist (bpos b)) . fst) accVic-      -- At least don't get closer to enemies, but don't stay adjacent.-      eqVic = filter (\(d, _) -> d == dist (bpos b) && d > 1) accVic-      rewardPath (d, p) =-        if p `elem` tgtPath then Just (9 * d, p)-        else if any (\q -> chessDist p q == 1) tgtPath then Just (d, p)-        else Nothing-      goodVic = mapMaybe rewardPath gtVic-                ++ filter ((`elem` tgtPath) . snd) eqVic-      pathVic = goodVic ++ if panic then accVic \\ goodVic else []-  return pathVic  -- keep it lazy, until other conditions verify danger+      eqVic = filter ((== dist (bpos b)) . fst) accVic+      ltVic = filter ((< dist (bpos b)) . fst) accVic+      rewardPath mult (d, p)+        | p `elem` tgtPath = (100 * mult * d, p)+        | any (\q -> chessDist p q == 1) tgtPath = (10 * mult * d, p)+        | otherwise = (mult * d, p)+      goodVic = map (rewardPath 10000) gtVic+                ++ map (rewardPath 100) eqVic+      badVic = map (rewardPath 1) ltVic+  return (goodVic, badVic)  -- keep it lazy

@@ -46,7 +46,6 @@ import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Content.TileKind as TK  type ToAny a = Strategy (RequestTimed a) -> Strategy RequestAnyAbility@@ -59,49 +58,60 @@ actionStrategy :: forall m. MonadClient m                => ActorId -> m (Strategy RequestAnyAbility) actionStrategy aid = do-  Kind.COps{corule} <- getsState scops-  let stdRuleset = Kind.stdRuleset corule-      nearby = rnearby stdRuleset   body <- getsState $ getActorBody aid   activeItems <- activeItemsClient aid   fact <- getsState $ (EM.! bfid body) . sfactionD   condTgtEnemyPresent <- condTgtEnemyPresentM aid   condTgtEnemyRemembered <- condTgtEnemyRememberedM aid+  condTgtEnemyAdjFriend <- condTgtEnemyAdjFriendM aid   condAnyFoeAdj <- condAnyFoeAdjM aid   threatDistL <- threatDistList aid   condHpTooLow <- condHpTooLowM aid   condOnTriggerable <- condOnTriggerableM aid   condBlocksFriends <- condBlocksFriendsM aid   condNoEqpWeapon <- condNoEqpWeaponM aid-  condNoUsableWeapon <- null <$> pickWeaponClient aid aid+  let condNoUsableWeapon = all (not . isMelee) activeItems+  condEnoughGear <- condEnoughGearM aid   condFloorWeapon <- condFloorWeaponM aid-  condCanProject <- condCanProjectM aid+  condCanProject <- condCanProjectM False aid   condNotCalmEnough <- condNotCalmEnoughM aid   condDesirableFloorItem <- condDesirableFloorItemM aid   condMeleeBad <- condMeleeBadM aid-  fleeL <- fleeList False aid-  panicFleeL <- fleeList True aid-  let condThreatAdj = not $ null $ takeWhile ((== 1) . fst) threatDistL+  condTgtNonmoving <- condTgtNonmovingM aid+  aInAmbient <- getsState $ actorInAmbient body+  explored <- getsClient sexplored+  (fleeL, badVic) <- fleeList aid+  let lidExplored = ES.member (blid body) explored+      panicFleeL = fleeL ++ badVic+      actorShines = sumSlotNoFilter IK.EqpSlotAddLight activeItems > 0+      condThreatAdj = not $ null $ takeWhile ((== 1) . fst) threatDistL       condThreatAtHand = not $ null $ takeWhile ((<= 2) . fst) threatDistL-      condThreatNearby = not $ null $ takeWhile ((<= nearby) . fst) threatDistL+      condThreatNearby = not $ null $ takeWhile ((<= 9) . fst) threatDistL       speed1_5 = speedScale (3%2) (bspeed body activeItems)       condFastThreatAdj = any (\(_, (_, b)) -> bspeed b activeItems > speed1_5)                           $ takeWhile ((== 1) . fst) threatDistL-      condCanFlee = not (null fleeL || condFastThreatAdj)-  actorSk <- actorSkillsClient aid-  let stratToFreq :: MonadStateRead m+      heavilyDistressed =  -- actor hit by a proj or similarly distressed+        deltaSerious (bcalmDelta body)+  let actorMaxSk = sumSkills activeItems+      abInMaxSkill ab = EM.findWithDefault 0 ab actorMaxSk > 0+      stratToFreq :: MonadStateRead m                   => Int -> m (Strategy RequestAnyAbility)                   -> m (Frequency RequestAnyAbility)       stratToFreq scale mstrat = do         st <- mstrat-        return $! scaleFreq scale $ bestVariant st  -- TODO: flatten instead?+        return $! if scale == 0+                  then mzero+                  else scaleFreq scale $ bestVariant st  -- TODO: flatten instead?+      -- Order matters within the list, because it's summed with .| after+      -- filtering. Also, the results of prefix, distant and suffix+      -- are summed with .| at the end.       prefix, suffix :: [([Ability], m (Strategy RequestAnyAbility), Bool)]       prefix =-        [ ( [AbApply], (toAny :: ToAny AbApply)+        [ ( [AbApply], (toAny :: ToAny 'AbApply)             <$> applyItem aid ApplyFirstAid           , condHpTooLow && not condAnyFoeAdj             && not condOnTriggerable )  -- don't block stairs, perhaps ascend-        , ( [AbTrigger], (toAny :: ToAny AbTrigger)+        , ( [AbTrigger], (toAny :: ToAny 'AbTrigger)             <$> trigger aid True               -- flee via stairs, even if to wrong level               -- may return via different stairs@@ -109,238 +119,320 @@             && ((condNotCalmEnough || condHpTooLow)                 && condThreatNearby && not condTgtEnemyPresent                 || condMeleeBad && condThreatAdj) )-        , ( [AbMove]-          , flee aid fleeL-          , condMeleeBad && condThreatAdj && condCanFlee )         , ( [AbDisplace]           , displaceFoe aid  -- only swap with an enemy to expose him           , condBlocksFriends && condAnyFoeAdj             && not condOnTriggerable && not condDesirableFloorItem )-        , ( [AbMoveItem], (toAny :: ToAny AbMoveItem)+        , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem)             <$> pickup aid True-          , condNoEqpWeapon && condFloorWeapon && not condHpTooLow )-        , ( [AbMelee], (toAny :: ToAny AbMelee)+          , condNoEqpWeapon && condFloorWeapon && not condHpTooLow+            && abInMaxSkill AbMelee )+        , ( [AbMelee], (toAny :: ToAny 'AbMelee)             <$> meleeBlocker aid  -- only melee target or blocker           , condAnyFoeAdj-            || EM.findWithDefault 0 AbDisplace actorSk <= 0-                 -- melee friends, not displace+            || not (abInMaxSkill AbDisplace)  -- melee friends, not displace                && fleaderMode (gplayer fact) == LeaderNull  -- not restrained-               && (condTgtEnemyPresent || condTgtEnemyRemembered) )  -- excited-        , ( [AbTrigger], (toAny :: ToAny AbTrigger)+               && condTgtEnemyPresent )  -- excited+        , ( [AbTrigger], (toAny :: ToAny 'AbTrigger)             <$> trigger aid False-          , condOnTriggerable && not condDesirableFloorItem )+          , condOnTriggerable && not condDesirableFloorItem+            && (lidExplored || condEnoughGear)+            && not condTgtEnemyPresent )+        , ( [AbMove]+          , flee aid fleeL+          , condMeleeBad && not condFastThreatAdj+            -- Don't keep fleeing if was just hit, unless can't melee at all.+            && not (heavilyDistressed+                    && abInMaxSkill AbMelee+                    && not condNoUsableWeapon)+            && condThreatAtHand )         , ( [AbDisplace]  -- prevents some looping movement           , displaceBlocker aid  -- fires up only when path blocked           , not condDesirableFloorItem )-        , ( [AbMoveItem], (toAny :: ToAny AbMoveItem)+        , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem)             <$> equipItems aid  -- doesn't take long, very useful if safe                                 -- only if calm enough, so high priority-          , not condAnyFoeAdj && not condDesirableFloorItem ) ]+          , not (condAnyFoeAdj+                 || condDesirableFloorItem+                 || condNotCalmEnough) )+        ]+      -- Order doesn't matter, scaling does.       distant :: [([Ability], m (Frequency RequestAnyAbility), Bool)]       distant =-        [ ( [AbProject]  -- for high-value target, shoot even in melee-          , stratToFreq 2 $ (toAny :: ToAny AbProject)+        [ ( [AbMoveItem]+          , stratToFreq 20000 $ (toAny :: ToAny 'AbMoveItem)+            <$> yieldUnneeded aid  -- 20000 to unequip ASAP, unless is thrown+          , True )+        , ( [AbProject]  -- for high-value target, shoot even in melee+          , stratToFreq 2 $ (toAny :: ToAny 'AbProject)             <$> projectItem aid           , condTgtEnemyPresent && condCanProject && not condOnTriggerable )         , ( [AbApply]-          , stratToFreq 2 $ (toAny :: ToAny AbApply)-            <$> applyItem aid ApplyAll  -- use any option or scroll+          , stratToFreq 2 $ (toAny :: ToAny 'AbApply)+            <$> applyItem aid ApplyAll  -- use any potion or scroll           , (condTgtEnemyPresent || condThreatNearby)  -- can affect enemies             && not condOnTriggerable )         , ( [AbMove]-          , stratToFreq (if not condTgtEnemyPresent || condMeleeBad-                         then 1+          , stratToFreq (if not condTgtEnemyPresent+                         then 3  -- if enemy only remembered, investigate anyway+                         else if condTgtNonmoving+                         then 0+                         else if condTgtEnemyAdjFriend+                         then 1000  -- friends probably pummeled, go to help                          else 100)-            $ chase aid True+            $ chase aid True (condMeleeBad && condThreatNearby+                              && not aInAmbient && not actorShines)           , (condTgtEnemyPresent || condTgtEnemyRemembered)-            && not condDesirableFloorItem-            && not condNoUsableWeapon ) ]+            && not (condDesirableFloorItem && not condThreatAtHand)+            && abInMaxSkill AbMelee+            && not condNoUsableWeapon )+        ]+      -- Order matters again.       suffix =-        [ ( [AbMoveItem], (toAny :: ToAny AbMoveItem)-            <$> pickup aid False-          , True )  -- unconditionally, e.g., to give to other party members-        , ( [AbMove]-          , flee aid fleeL-          , condMeleeBad && (condNotCalmEnough && condThreatNearby-                             || condThreatAtHand)-            && condCanFlee )-        , ( [AbMelee], (toAny :: ToAny AbMelee)+        [ ( [AbMelee], (toAny :: ToAny 'AbMelee)             <$> meleeAny aid  -- avoid getting damaged for naught           , condAnyFoeAdj )         , ( [AbMove]-            -- TODO: forget old target (e.g., tile), to start shooting,-            -- unless can't shoot, etc.-          , flee aid panicFleeL  -- panic mode; chasing would be pointless-          , condMeleeBad && condThreatNearby && (condNotCalmEnough-                                                 || condThreatAtHand-                                                 || condNoUsableWeapon) )-        , ( [AbMoveItem], (toAny :: ToAny AbMoveItem)-            <$> unEquipItems aid  -- late, because better to throw than unequip+          , flee aid panicFleeL  -- ultimate panic mode, displaces foes+          , condAnyFoeAdj )+        , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem)+            <$> pickup aid False+          , not condThreatAtHand )  -- e.g., to give to other party members+        , ( [AbMoveItem], (toAny :: ToAny 'AbMoveItem)+            <$> unEquipItems aid  -- late, because these items not bad           , True )         , ( [AbMove]-          , chase aid False-          , True )-        , ( [AbWait], (toAny :: ToAny AbWait)+          , chase aid True (condTgtEnemyPresent+                            -- Don't keep hiding in darkness if hit right now,+                            -- unless can't melee at all.+                            && not (heavilyDistressed+                                    && abInMaxSkill AbMelee+                                    && not condNoUsableWeapon)+                            && condMeleeBad && condThreatNearby+                            && not aInAmbient && not actorShines)+          , not (condTgtNonmoving && condThreatAtHand) )++            -- TODO: unless tgt can't melee+        ]+      fallback =+        [ ( [AbWait], (toAny :: ToAny 'AbWait)             <$> waitBlockNow             -- Wait until friends sidestep; ensures strategy is never empty.             -- TODO: try to switch leader away before that (we already             -- switch him afterwards)-          , True ) ]+          , True )+        ]       -- TODO: don't msum not to evaluate until needed-      abInSkill ab = EM.findWithDefault 0 ab actorSk > 0+  -- Check current, not maximal skills, since this can be a non-leader action.+  actorSk <- actorSkillsClient aid+  let abInSkill ab = EM.findWithDefault 0 ab actorSk > 0       checkAction :: ([Ability], m a, Bool) -> Bool-      checkAction (abts, _, cond) = cond && all abInSkill abts+      checkAction (abts, _, cond) = all abInSkill abts && cond       sumS abAction = do         let as = filter checkAction abAction-        strats <- sequence $ map (\(_, m, _) -> m) as+        strats <- mapM (\(_, m, _) -> m) as         return $! msum strats       sumF abFreq = do         let as = filter checkAction abFreq-        strats <- sequence $ map (\(_, m, _) -> m) as+        strats <- mapM (\(_, m, _) -> m) as         return $! msum strats-      combineDistant as = fmap liftFrequency $ sumF as+      combineDistant as = liftFrequency <$> sumF as   sumPrefix <- sumS prefix   comDistant <- combineDistant distant   sumSuffix <- sumS suffix-  return $! sumPrefix .| comDistant .| sumSuffix+  sumFallback <- sumS fallback+  return $! sumPrefix .| comDistant .| sumSuffix .| sumFallback  -- | A strategy to always just wait.-waitBlockNow :: MonadClient m => m (Strategy (RequestTimed AbWait))+waitBlockNow :: MonadClient m => m (Strategy (RequestTimed 'AbWait)) waitBlockNow = return $! returN "wait" ReqWait  pickup :: MonadClient m-       => ActorId -> Bool -> m (Strategy (RequestTimed AbMoveItem))+       => ActorId -> Bool -> m (Strategy (RequestTimed 'AbMoveItem)) pickup aid onlyWeapon = do   benItemL <- benGroundItems aid-  let isWeapon (_, (_, itemFull)) =-        maybe False ((== IK.EqpSlotWeapon) . fst)-        $ strengthEqpSlot $ itemBase itemFull+  b <- getsState $ getActorBody aid+  activeItems <- activeItemsClient aid+  -- This calmE is outdated when one of the items increases max Calm+  -- (e.g., in pickup, which handles many items at once), but this is OK,+  -- the server accepts item movement based on calm at the start, not end+  -- or in the middle.+  -- The calmE is inaccurate also if an item not IDed, but that's intended+  -- and the server will ignore and warn (and content may avoid that,+  -- e.g., making all rings identified)+  let calmE = calmEnough b activeItems+      isWeapon (_, (_, itemFull)) = isMeleeEqp itemFull       filterWeapon | onlyWeapon = filter isWeapon                    | otherwise = id-      cmp ((Nothing, _), _) = 5  -- experimenting is fun-      cmp ((Just (n, _), _), _) = abs n-  -- Pick up the best desirable item, if any.-  case reverse $ sortBy (comparing cmp) $ filterWeapon benItemL of-    ((_, (k, _)), (iid, itemFull)) : _ -> do-      b <- getsState $ getActorBody aid-      -- TODO: instead of pickup to eqp and then move to inv, pickup to inv-      let toCStore = if goesIntoInv (itemBase itemFull)-                        || eqpOverfull b k-                     then CInv-                     else CEqp-      return $! returN "pickup" $ ReqMoveItem iid k CGround toCStore-    [] -> return reject+      prepareOne (oldN, l4) ((_, (k, _)), (iid, itemFull)) =+        -- TODO: instead of pickup to eqp and then move to inv, pickup to inv+        let n = oldN + k+            (newN, toCStore)+              | calmE && goesIntoSha itemFull = (oldN, CSha)+              | goesIntoInv itemFull || eqpOverfull b n = (oldN, CInv)+              | otherwise = (n, CEqp)+        in (newN, (iid, k, CGround, toCStore) : l4)+      (_, prepared) = foldl' prepareOne (0, []) $ filterWeapon benItemL+  return $! if null prepared+            then reject+            else returN "pickup" $ ReqMoveItems prepared -equipItems :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMoveItem))+equipItems :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) equipItems aid = do-  cops@Kind.COps{corule} <- getsState scops-  let RuleKind{rsharedStash} = Kind.stdRuleset corule+  cops <- getsState scops   body <- getsState $ getActorBody aid   activeItems <- activeItemsClient aid+  let calmE = calmEnough body activeItems   fact <- getsState $ (EM.! bfid body) . sfactionD   eqpAssocs <- fullAssocsClient aid [CEqp]   invAssocs <- fullAssocsClient aid [CInv]   shaAssocs <- fullAssocsClient aid [CSha]+  condAnyFoeAdj <- condAnyFoeAdjM aid   condLightBetrays <- condLightBetraysM aid-  let improve :: CStore -> ([(Int, (ItemId, ItemFull))],-                            [(Int, (ItemId, ItemFull))])-              -> Strategy (RequestTimed AbMoveItem)-      improve fromCStore (bestInv, bestEqp) =-        case (bestInv, bestEqp) of-          ((_, (iidInv, _)) : _, []) | not (eqpOverfull body 1) ->-            returN "wield any"-            $ ReqMoveItem iidInv 1 fromCStore CEqp-          ((vInv, (iidInv, _)) : _, (vEqp, _) : _) | not (eqpOverfull body 1)-                                                     && vInv > vEqp ->-            returN "wield better"-            $ ReqMoveItem iidInv 1 fromCStore CEqp-          _ -> reject+  condTgtEnemyPresent <- condTgtEnemyPresentM aid+  let improve :: CStore+              -> (Int, [(ItemId, Int, CStore, CStore)])+              -> ( IK.EqpSlot+                 , ( [(Int, (ItemId, ItemFull))]+                   , [(Int, (ItemId, ItemFull))] ) )+              -> (Int, [(ItemId, Int, CStore, CStore)])+      improve fromCStore (oldN, l4) (slot, (bestInv, bestEqp)) =+        let n = 1 + oldN+        in case (bestInv, bestEqp) of+          ((_, (iidInv, _)) : _, []) | not (eqpOverfull body n) ->+            (n, (iidInv, 1, fromCStore, CEqp) : l4)+          ((vInv, (iidInv, _)) : _, (vEqp, _) : _)+            | not (eqpOverfull body n)+              && (vInv > vEqp || not (toShare slot)) ->+                (n, (iidInv, 1, fromCStore, CEqp) : l4)+          _ -> (oldN, l4)       -- We filter out unneeded items. In particular, we ignore them in eqp       -- when comparing to items we may want to equip. Anyway, the unneeded       -- items should be removed in yieldUnneeded earlier or soon after.       filterNeeded (_, itemFull) =-        not $ unneeded cops condLightBetrays body activeItems fact itemFull+        not $ unneeded cops condAnyFoeAdj condLightBetrays+                       condTgtEnemyPresent (not calmE)+                       body activeItems fact itemFull       bestThree = bestByEqpSlot (filter filterNeeded eqpAssocs)                                 (filter filterNeeded invAssocs)                                 (filter filterNeeded shaAssocs)-      bEqpInv = msum $ map (improve CInv)-                $ map (\(_, (eqp, inv, _)) -> (inv, eqp)) bestThree-      bEqpSha = msum $ map (improve CSha)-                $ map (\(_, (eqp, _, sha)) -> (sha, eqp)) bestThree-  if nullStrategy bEqpInv-    then if rsharedStash && calmEnough body activeItems-         then return $! bEqpSha-         else return reject-    else return $! bEqpInv+      bEqpInv = foldl' (improve CInv) (0, [])+                $ map (\((slot, _), (eqp, inv, _)) ->+                        (slot, (inv, eqp))) bestThree+      bEqpBoth | calmE =+                   foldl' (improve CSha) bEqpInv+                   $ map (\((slot, _), (eqp, _, sha)) ->+                           (slot, (sha, eqp))) bestThree+               | otherwise = bEqpInv+      (_, prepared) = bEqpBoth+  return $! if null prepared+            then reject+            else returN "equipItems" $ ReqMoveItems prepared +toShare :: IK.EqpSlot -> Bool+toShare IK.EqpSlotPeriodic = False+toShare _ = True++yieldUnneeded :: MonadClient m+              => ActorId -> m (Strategy (RequestTimed 'AbMoveItem))+yieldUnneeded aid = do+  cops <- getsState scops+  body <- getsState $ getActorBody aid+  activeItems <- activeItemsClient aid+  let calmE = calmEnough body activeItems+  fact <- getsState $ (EM.! bfid body) . sfactionD+  eqpAssocs <- fullAssocsClient aid [CEqp]+  condAnyFoeAdj <- condAnyFoeAdjM aid+  condLightBetrays <- condLightBetraysM aid+  condTgtEnemyPresent <- condTgtEnemyPresentM aid+      -- Here AI hides from the human player the Ring of Speed And Bleeding,+      -- which is a bit harsh, but fair. However any subsequent such+      -- rings will not be picked up at all, so the human player+      -- doesn't lose much fun. Additionally, if AI learns alchemy later on,+      -- they can repair the ring, wield it, drop at death and it's+      -- in play again.+  let yieldSingleUnneeded (iidEqp, itemEqp) =+        let csha = if calmE then CSha else CInv+        in if harmful cops body activeItems fact itemEqp+           then [(iidEqp, itemK itemEqp, CEqp, CInv)]+           else if hinders condAnyFoeAdj condLightBetrays+                           condTgtEnemyPresent (not calmE)+                           body activeItems itemEqp+           then [(iidEqp, itemK itemEqp, CEqp, csha)]+           else []+      yieldAllUnneeded = concatMap yieldSingleUnneeded eqpAssocs+  return $! if null yieldAllUnneeded+            then reject+            else returN "yieldUnneeded" $ ReqMoveItems yieldAllUnneeded+ unEquipItems :: MonadClient m-             => ActorId -> m (Strategy (RequestTimed AbMoveItem))+             => ActorId -> m (Strategy (RequestTimed 'AbMoveItem)) unEquipItems aid = do-  cops@Kind.COps{corule} <- getsState scops-  let RuleKind{rsharedStash} = Kind.stdRuleset corule+  cops <- getsState scops   body <- getsState $ getActorBody aid   activeItems <- activeItemsClient aid+  let calmE = calmEnough body activeItems   fact <- getsState $ (EM.! bfid body) . sfactionD   eqpAssocs <- fullAssocsClient aid [CEqp]   invAssocs <- fullAssocsClient aid [CInv]   shaAssocs <- fullAssocsClient aid [CSha]+  condAnyFoeAdj <- condAnyFoeAdjM aid   condLightBetrays <- condLightBetraysM aid-  let yieldSingleUnneeded (iidEqp, itemEqp) =-        let csha = if rsharedStash && calmEnough body activeItems-                   then CSha-                   else CInv-        in if harmful cops body activeItems fact itemEqp-           then Just $ ReqMoveItem iidEqp (itemK itemEqp) CEqp CInv  -- throw-           else if hinders condLightBetrays body activeItems itemEqp-           then Just $ ReqMoveItem iidEqp (itemK itemEqp) CEqp csha  -- share-           else Nothing-      yieldUnneeded = mapMaybe yieldSingleUnneeded eqpAssocs-      improve :: CStore -> ( IK.EqpSlot+  condTgtEnemyPresent <- condTgtEnemyPresentM aid+      -- Here AI hides from the human player the Ring of Speed And Bleeding,+      -- which is a bit harsh, but fair. However any subsequent such+      -- rings will not be picked up at all, so the human player+      -- doesn't lose much fun. Additionally, if AI learns alchemy later on,+      -- they can repair the ring, wield it, drop at death and it's+      -- in play again.+  let improve :: CStore -> ( IK.EqpSlot                            , ( [(Int, (ItemId, ItemFull))]                              , [(Int, (ItemId, ItemFull))] ) )-              -> Strategy (RequestTimed AbMoveItem)-      improve fromCStore (slot, (bestInv, bestEqp)) =-        case (bestInv, bestEqp) of-          _ | slot == IK.EqpSlotPeriodic+              -> [(ItemId, Int, CStore, CStore)]+      improve fromCStore (slot, (bestSha, bestEOrI)) =+        case (bestSha, bestEOrI) of+          _ | not (toShare slot)               && fromCStore == CEqp-              && not (eqpOverfull body 0) ->-            -- Don't get rid of periodic items from eqp unless eqp full.-            reject-          (_, (vEqp, (iidEqp, _)) : _) | getK bestEqp > 1-                                         && betterThanInv vEqp bestInv ->+              && not (eqpOverfull body 1) ->  -- keep periodic items up to M-1+            []+          (_, (vEOrI, (iidEOrI, _)) : _) | (toShare slot || fromCStore == CInv)+                                           && getK bestEOrI > 1+                                           && betterThanSha vEOrI bestSha ->             -- To share the best items with others, if they care.-            returN "yield rest"-            $ ReqMoveItem iidEqp (getK bestEqp - 1) fromCStore CSha-          (_, _ : (vEqp, (iidEqp, _)) : _) | betterThanInv vEqp bestInv ->+            [(iidEOrI, getK bestEOrI - 1, fromCStore, CSha)]+          (_, _ : (vEOrI, (iidEOrI, _)) : _) | (toShare slot+                                                || fromCStore == CInv)+                                               && betterThanSha vEOrI bestSha ->             -- To share the second best items with others, if they care.-            returN "yield worse"-            $ ReqMoveItem iidEqp (getK bestEqp) fromCStore CSha-          _ -> reject+            [(iidEOrI, getK bestEOrI, fromCStore, CSha)]+          (_, (vEOrI, (_, _)) : _) | fromCStore == CEqp+                                     && eqpOverfull body 1+                                     && worseThanSha vEOrI bestSha ->+            -- To make place in eqp for an item better than any ours.+            [(fst $ snd $ last bestEOrI, 1, fromCStore, CSha)]+          _ -> []       getK [] = 0       getK ((_, (_, itemFull)) : _) = itemK itemFull-      betterThanInv _ [] = True-      betterThanInv vEqp ((vInv, _) : _) = vEqp > vInv-      bestThree = bestByEqpSlot eqpAssocs invAssocs shaAssocs-      bInvSha = msum $ map (improve CInv)+      betterThanSha _ [] = True+      betterThanSha vEOrI ((vSha, _) : _) = vEOrI > vSha+      worseThanSha _ [] = False+      worseThanSha vEOrI ((vSha, _) : _) = vEOrI < vSha+      filterNeeded (_, itemFull) =+        not $ unneeded cops condAnyFoeAdj condLightBetrays+                       condTgtEnemyPresent (not calmE)+                       body activeItems fact itemFull+      bestThree =+        bestByEqpSlot eqpAssocs invAssocs (filter filterNeeded shaAssocs)+      bInvSha = concatMap (improve CInv)                 $ map (\((slot, _), (_, inv, sha)) ->                         (slot, (sha, inv))) bestThree-      bEqpSha = msum $ map (improve CEqp)+      bEqpSha = concatMap (improve CEqp)                 $ map (\((slot, _), (eqp, _, sha)) ->                         (slot, (sha, eqp))) bestThree-  case yieldUnneeded of-    [] -> if rsharedStash && calmEnough body activeItems-          then if nullStrategy bInvSha-               then return $! bEqpSha-               else return $! bInvSha-          else return reject-    _ ->-      -- Here AI hides from the human player the Ring of Speed And Bleeding,-      -- which is a bit harsh, but fair. However any subsequent such-      -- rings will not be picked up at all, so the human player-      -- doesn't lose much fun. Additionally, if AI learns alchemy later on,-      -- they can repair the ring, wield it, drop at death and it's-      -- in play again.-      return $! liftFrequency $ uniformFreq "yield unneeded" yieldUnneeded+      prepared = if calmE then bInvSha ++ bEqpSha else []+  return $! if null prepared+            then reject+            else returN "unEquipItems" $ ReqMoveItems prepared  groupByEqpSlot :: [(ItemId, ItemFull)]                -> M.Map (IK.EqpSlot, Text) [(ItemId, ItemFull)]@@ -364,35 +456,12 @@       shaMap = M.map (\g -> ([], [], g)) $ groupByEqpSlot shaAssocs       appendThree (g1, g2, g3) (h1, h2, h3) = (g1 ++ h1, g2 ++ h2, g3 ++ h3)       eqpInvShaMap = M.unionsWith appendThree [eqpMap, invMap, shaMap]-      bestSingle eqpSlot g = strongestSlot eqpSlot g+      bestSingle = strongestSlot       bestThree (eqpSlot, _) (g1, g2, g3) = (bestSingle eqpSlot g1,                                              bestSingle eqpSlot g2,                                              bestSingle eqpSlot g3)   in M.assocs $ M.mapWithKey bestThree eqpInvShaMap -hinders :: Bool -> Actor -> [ItemFull] -> ItemFull -> Bool-hinders condLightBetrays body activeItems itemFull =-  -- Fast actors want to hide in darkness to ambush opponents and want-  -- to hit hard for the short span they get to survive melee.-  (bspeed body activeItems > speedNormal-   && (isJust (strengthFromEqpSlot IK.EqpSlotAddLight itemFull)-       || 0 > fromMaybe 0 (strengthFromEqpSlot IK.EqpSlotAddHurtMelee-                                               itemFull)-       || 0 > fromMaybe 0 (strengthFromEqpSlot IK.EqpSlotAddHurtRanged-                                               itemFull)))-  -- Distressed actors want to hide in the dark.-  || (let heavilyDistressed =  -- actor hit by a proj or similarly distressed-            deltaSerious (bcalmDelta body)-      in condLightBetrays && heavilyDistressed-         && isJust (strengthFromEqpSlot IK.EqpSlotAddLight itemFull))-  -- TODO:-  -- teach AI to turn shields OFF (or stash) when ganging up on an enemy-  -- (friends close, only one enemy close)-  -- and turning on afterwards (AI plays for time, especially spawners-  -- so shields are preferable by default;-  -- also, turning on when no friends and enemies close is too late,-  -- AI should flee or fire at such times, not muck around with eqp)- harmful :: Kind.COps -> Actor -> [ItemFull] -> Faction -> ItemFull -> Bool harmful cops body activeItems fact itemFull =   -- Items that are known and their effects are not stricly beneficial@@ -400,14 +469,22 @@   maybe False (\(u, _) -> u <= 0)     (totalUsefulness cops body activeItems fact itemFull) -unneeded :: Kind.COps -> Bool -> Actor -> [ItemFull] -> Faction -> ItemFull+unneeded :: Kind.COps -> Bool -> Bool -> Bool -> Bool+         -> Actor -> [ItemFull] -> Faction -> ItemFull          -> Bool-unneeded cops condLightBetrays body activeItems fact itemFull =+unneeded cops condAnyFoeAdj condLightBetrays+         condTgtEnemyPresent condNotCalmEnough+         body activeItems fact itemFull =   harmful cops body activeItems fact itemFull-  || hinders condLightBetrays body activeItems itemFull+  || hinders condAnyFoeAdj condLightBetrays+             condTgtEnemyPresent condNotCalmEnough+             body activeItems itemFull+  || let calm10 = calmEnough10 body activeItems  -- unneeded risk+         itemLit = isJust $ strengthFromEqpSlot IK.EqpSlotAddLight itemFull+     in itemLit && not calm10  -- Everybody melees in a pinch, even though some prefer ranged attacks.-meleeBlocker :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMelee))+meleeBlocker :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMelee)) meleeBlocker aid = do   b <- getsState $ getActorBody aid   fact <- getsState $ (EM.! bfid b) . sfactionD@@ -417,9 +494,9 @@     Just (_, Just (_ : q : _, (goal, _))) -> do       -- We prefer the goal (e.g., when no accessible, but adjacent),       -- but accept @q@ even if it's only a blocking enemy position.-      let maim = if adjacent (bpos b) goal then Just goal-                 else if adjacent (bpos b) q then Just q-                 else Nothing  -- MeleeDistant+      let maim | adjacent (bpos b) goal = Just goal+               | adjacent (bpos b) q = Just q+               | otherwise = Nothing  -- MeleeDistant       mBlocker <- case maim of         Nothing -> return Nothing         Just aim -> getsState $ posToActor aim (blid b)@@ -436,7 +513,7 @@                     && EM.findWithDefault 0 AbMove actorSk > 0  -- blocked move                     && bhp body2 < bhp b)  -- respect power             then do-              mel <- pickWeaponClient aid aid2+              mel <- maybeToList <$> pickWeaponClient aid aid2               return $! liftFrequency $ uniformFreq "melee in the way" mel             else return reject         Nothing -> return reject@@ -444,7 +521,7 @@  -- Everybody melees in a pinch, skills and weapons allowing, -- even though some prefer ranged attacks.-meleeAny :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbMelee))+meleeAny :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbMelee)) meleeAny aid = do   b <- getsState $ getActorBody aid   fact <- getsState $ (EM.! bfid b) . sfactionD@@ -452,13 +529,20 @@   let adjFoes = filter (adjacent (bpos b) . bpos . snd) allFoes   mels <- mapM (pickWeaponClient aid . fst) adjFoes       -- TODO: prioritize somehow-  let freq = uniformFreq "melee adjacent" $ concat mels+  let freq = uniformFreq "melee adjacent" $ catMaybes mels   return $! liftFrequency freq  -- TODO: take charging status into account--- Fast monsters don't pay enough attention to features.+-- TODO: make sure the stairs are specifically targetted and not+-- an item on them, etc., so that we don't leave level if items visible.+-- When invalidating target, make sure the stairs should really be taken.+-- | The level the actor is on is either explored or the actor already+-- has a weapon equipped, so no need to explore further, he tries to find+-- enemies on other levels.+-- We don't verify the stairs are targeted by the actor, but at least+-- the actor doesn't target a visible enemy at this point. trigger :: MonadClient m-        => ActorId -> Bool -> m (Strategy (RequestTimed AbTrigger))+        => ActorId -> Bool -> m (Strategy (RequestTimed 'AbTrigger)) trigger aid fleeViaStairs = do   cops@Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops   dungeon <- getsState sdungeon@@ -470,70 +554,69 @@   lvl <- getLevel lid   unexploredD <- unexploredDepth   s <- getState-  per <- getPerFid lid-  let canSee = ES.member (bpos b) (totalVisible per)-      unexploredCurrent = ES.notMember lid explored+  let lidExplored = ES.member lid explored       allExplored = ES.size explored == EM.size dungeon       t = lvl `at` bpos b       feats = TK.tfeature $ okind t       ben feat = case feat of-        TK.Cause (IK.Ascend k) ->  -- change levels sensibly, in teams-          let aimless = ftactic (gplayer fact) `elem` [TRoam, TPatrol]-              easeDelta = abs (fromEnum lid) - abs (fromEnum lid + k)+        TK.Cause (IK.Ascend k) -> do -- change levels sensibly, in teams+          (lid2, pos2) <- getsState $ whereTo lid (bpos b) k . sdungeon+          per <- getPerFid lid2+          let canSee = ES.member (bpos b) (totalVisible per)+              aimless = ftactic (gplayer fact) `elem` [TRoam, TPatrol]+              easier = signum k /= signum (fromEnum lid)               unexpForth = unexploredD (signum k) lid               unexpBack = unexploredD (- signum k) lid-              expBenefit =-                if aimless-                then 100  -- faction is not exploring, so switch at will-                else if unexploredCurrent-                then 0  -- don't leave the level until explored-                else if unexpForth-                then if easeDelta > 0  -- alway try as easy level as possible-                        || not unexpBack  -- no other choice for exploration-                     then 1000 * abs easeDelta-                     else 0-                else if unexpBack-                then 0  -- wait for stairs in the opposite direciton-                else if lescape lvl-                then 0  -- all explored, stay on the escape level-                else 2  -- no escape anywhere, switch levels occasionally-              (lid2, pos2) = whereTo lid (bpos b) k dungeon+              expBenefit+                | aimless = 100  -- faction is not exploring, so switch at will+                | unexpForth =+                    if easier  -- alway try as easy level as possible+                       || not unexpBack+                          && lidExplored -- no other choice for exploration+                    then 1000+                    else 0+                | not lidExplored = 0  -- fully explore current+                | unexpBack = 0  -- wait for stairs in the opposite direciton+                | not $ null $ lescape lvl = 0+                    -- all explored, stay on the escape level+                | otherwise = 2  -- no escape, switch levels occasionally               actorsThere = posToActors pos2 lid2 s-          in if boldpos b == bpos b   -- probably used stairs last turn+          return $!+             if boldpos b == bpos b   -- probably used stairs last turn                 && boldlid b == lid2  -- in the opposite direction              then 0  -- avoid trivial loops (pushing, being pushed, etc.)-             else let leaderless = fleaderMode (gplayer fact) == LeaderNull-                      eben = case actorsThere of+             else let eben = case actorsThere of                         [] | canSee -> expBenefit-                        _ | leaderless -> 0  -- leaderless clog stairs easily                         _ -> min 1 expBenefit  -- risk pushing                   in if fleeViaStairs                      then 1000 * eben + 1  -- strongly prefer correct direction                      else eben-        TK.Cause ef@IK.Escape{} -> do  -- flee via this way, too+        TK.Cause ef@IK.Escape{} -> return $  -- flee via this way, too           -- Only some factions try to escape but they first explore all           -- for high score.           if not (fcanEscape $ gplayer fact) || not allExplored           then 0           else effectToBenefit cops b activeItems fact ef         TK.Cause ef | not fleeViaStairs ->-          effectToBenefit cops b activeItems fact ef-        _ -> 0-      benFeat = zip (map ben feats) feats+          return $! effectToBenefit cops b activeItems fact ef+        _ -> return 0+  benFeats <- mapM ben feats+  let benFeat = zip benFeats feats   return $! liftFrequency $ toFreq "trigger"-         $ [ (benefit, ReqTrigger (Just feat))-           | (benefit, feat) <- benFeat-           , benefit > 0 ]+    [ (benefit, ReqTrigger (Just feat))+    | (benefit, feat) <- benFeat+    , benefit > 0 ] -projectItem :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbProject))+projectItem :: MonadClient m => ActorId -> m (Strategy (RequestTimed 'AbProject)) projectItem aid = do   btarget <- getsClient $ getTarget aid-  b@Actor{bpos} <- getsState $ getActorBody aid+  b <- getsState $ getActorBody aid   mfpos <- aidTgtToPos aid (blid b) btarget   seps <- getsClient seps   case (btarget, mfpos) of+    (_, Just fpos) | chessDist (bpos b) fpos == 1 -> return reject     (Just TEnemy{}, Just fpos) -> do-      mnewEps <- makeLine b fpos seps+      mnewEps <- makeLine False b fpos seps       case mnewEps of         Just newEps -> do           actorSk <- actorSkillsClient aid@@ -547,26 +630,23 @@           localTime <- getsState $ getLocalTime (blid b)           let coeff CGround = 2               coeff COrgan = 3  -- can't give to others-              coeff CEqp = 1+              coeff CEqp = 100000  -- must hinder currently               coeff CInv = 1               coeff CSha = undefined  -- banned-              fRanged ((mben, (_, cstore)), (iid, itemFull@ItemFull{..})) =-                let it1 = case strengthFromEqpSlot IK.EqpSlotTimeout-                                                   itemFull of-                      Nothing -> []-                      Just timeout ->-                        let timeoutTurns =-                              timeDeltaScale (Delta timeTurn) timeout-                            pending startT =-                              timeShift startT timeoutTurns > localTime-                        in filter pending itemTimer-                    len = length it1-                    recharged = len < itemK+              fRanged ( (mben, (_, cstore))+                      , (iid, itemFull@ItemFull{itemBase}) ) =+                -- We assume if the item has a timeout, most effects are under+                -- Recharging, so no point projecting if not recharged.+                -- This is not an obvious assumption, so recharging is not+                -- included in permittedProject and can be tweaked here easily.+                let recharged = hasCharge localTime itemFull                     trange = totalRange itemBase-                    bestRange = chessDist bpos fpos + 2  -- margin for fleeing+                    bestRange =+                      chessDist (bpos b) fpos + 2  -- margin for fleeing                     rangeMult =  -- penalize wasted or unsafely low range                       10 + max 0 (10 - abs (trange - bestRange))-                    durableBonus = if IK.Durable `elem` jfeature itemBase+                    durable = IK.Durable `elem` jfeature itemBase+                    durableBonus = if durable                                    then 2  -- we or foes keep it after the throw                                    else 1                     benR = durableBonus@@ -575,7 +655,10 @@                                Nothing -> -1  -- experiment if no options                                Just (_, ben) -> ben                            * (if recharged then 1 else 0)-                in if benR < 0 && trange >= chessDist bpos fpos+                in if -- Durable weapon is usually too useful for melee.+                      not (isMeleeEqp itemFull)+                      && benR < 0+                      && trange >= chessDist (bpos b) fpos                    then Just ( -benR * rangeMult `div` 10                              , ReqProject fpos newEps iid cstore )                    else Nothing@@ -588,17 +671,17 @@   deriving Eq  applyItem :: MonadClient m-          => ActorId -> ApplyItemGroup -> m (Strategy (RequestTimed AbApply))+          => ActorId -> ApplyItemGroup -> m (Strategy (RequestTimed 'AbApply)) applyItem aid applyGroup = do   actorSk <- actorSkillsClient aid+  b <- getsState $ getActorBody aid+  localTime <- getsState $ getLocalTime (blid b)   let skill = EM.findWithDefault 0 AbProject actorSk-      q _ itemFull b activeItems =+      q _ itemFull _ activeItems =         either (const False) id-        $ permittedApply " " skill itemFull b activeItems+        $ permittedApply " " localTime skill itemFull b activeItems   benList <- benAvailableItems aid q [CEqp, CInv, CGround]-  b <- getsState $ getActorBody aid   organs <- mapM (getsState . getItemBody) $ EM.keys $ borgan b-  localTime <- getsState $ getLocalTime (blid b)   let itemLegal itemFull = case applyGroup of         ApplyFirstAid ->           let getP (IK.RefillHP p) _ | p > 0 = True@@ -611,19 +694,11 @@         ApplyAll -> True       coeff CGround = 2       coeff COrgan = 3  -- can't give to others-      coeff CEqp = 1+      coeff CEqp = 100000  -- must hinder currently       coeff CInv = 1       coeff CSha = undefined  -- banned-      fTool ((mben, (_, cstore)), (iid, itemFull@ItemFull{..})) =-        let it1 = case strengthFromEqpSlot IK.EqpSlotTimeout itemFull of-              Nothing -> []-              Just timeout ->-                let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout-                    pending startT = timeShift startT timeoutTurns > localTime-                in filter pending itemTimer-            len = length it1-            recharged = len < itemK-            durableBonus = if IK.Durable `elem` jfeature itemBase+      fTool ((mben, (_, cstore)), (iid, itemFull@ItemFull{itemBase})) =+        let durableBonus = if IK.Durable `elem` jfeature itemBase                            then 5  -- we keep it after use                            else 1             oldGrps = map (toGroupName . jname) organs@@ -641,23 +716,20 @@               -- common and easy to drop organ, etc.               let newGrps = strengthDropOrgan itemFull                   hasDropOrgan = not $ null newGrps-              in hasDropOrgan && null (intersect newGrps oldGrps)+              in hasDropOrgan && null (newGrps `intersect` oldGrps)             benR = case mben of                      Nothing -> 0                        -- experimenting is fun, but it's better to risk-                       -- foes' skin than ours -- TODO: when {activated}+                       -- foes' skin than ours -- TODO: when {applied}                        -- is implemented, enable this for items too heavy,                        -- etc. for throwing                      Just (_, ben) -> ben-                   * (if recharged then 1 else 0)  -- wait until can be used                    * (if not createOrganAgain then 1 else 0)                    * (if not dropOrganVoid then 1 else 0)                    * durableBonus                    * coeff cstore-        in if itemLegal itemFull-           then if benR > 0-                then Just (benR, ReqApply iid cstore)-                else Nothing+        in if itemLegal itemFull && benR > 0+           then Just (benR, ReqApply iid cstore)            else Nothing       benTool = mapMaybe fTool benList   return $! liftFrequency $ toFreq "applyItem" benTool@@ -684,15 +756,15 @@   let friendlyFid fid = fid == bfid b || isAllied fact fid   friends <- getsState $ actorRegularList friendlyFid (blid b)   allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)-  let accessibleHere = accessible cops lvl $ bpos b  -- DisplaceAccess-      displaceable body =  -- DisplaceAccess, DisplaceDying, DisplaceSupported-        accessibleHere (bpos body)-        && adjacent (bpos body) (bpos b)+  let accessibleHere = accessible cops lvl $ bpos b+      displaceable body =  -- DisplaceAccess+        adjacent (bpos body) (bpos b) && accessibleHere (bpos body)       nFriends body = length $ filter (adjacent (bpos body) . bpos) friends       nFrHere = nFriends b + 1       qualifyActor (aid2, body2) = do         activeItems <- activeItemsClient aid2         dEnemy <- getsState $ dispEnemy aid aid2 activeItems+          -- DisplaceDying, DisplaceBraced, DisplaceImmobile, DisplaceSupported         let nFr = nFriends body2         return $! if displaceable body2 && dEnemy && nFr < nFrHere           then Just (nFr * nFr, bpos body2 `vectorToFrom` bpos b)@@ -716,7 +788,7 @@ displaceTowards aid source target = do   cops <- getsState scops   b <- getsState $ getActorBody aid-  assert (source == bpos b && adjacent source target) skip+  let !_A = assert (source == bpos b && adjacent source target) ()   lvl <- getLevel $ blid b   if boldpos b /= target -- avoid trivial loops      && accessible cops lvl source target then do  -- DisplaceAccess@@ -728,10 +800,13 @@         mtgtMPath <- getsClient $ EM.lookup aid2 . stargetD         case mtgtMPath of           Just (tgt, Just (p : q : rest, (goal, len)))-            | q == source && p == target -> do-              let newTgt = Just (tgt, Just (q : rest, (goal, len - 1)))+            | q == source && p == target+              || waitedLastTurn b2 -> do+              let newTgt = if q == source && p == target+                           then Just (tgt, Just (q : rest, (goal, len - 1)))+                           else Nothing               modifyClient $ \cli ->-                cli {stargetD = EM.alter (const $ newTgt) aid (stargetD cli)}+                cli {stargetD = EM.alter (const newTgt) aid (stargetD cli)}               return $! returN "displace friend" $ target `vectorToFrom` source           Just _ -> return reject           Nothing -> do@@ -740,17 +815,21 @@             dEnemy <- getsState $ dispEnemy aid aid2 activeItems             if not (isAtWar tfact (bfid b)) || dEnemy then               return $! returN "displace other" $ target `vectorToFrom` source-            else return reject  -- DisplaceDying, DisplaceSupported+            else return reject  -- DisplaceDying, etc.       _ -> return reject  -- DisplaceProjectiles or trying to displace leader   else return reject -chase :: MonadClient m => ActorId -> Bool -> m (Strategy RequestAnyAbility)-chase aid doDisplace = do+chase :: MonadClient m+      => ActorId -> Bool -> Bool -> m (Strategy RequestAnyAbility)+chase aid doDisplace avoidAmbient = do+  Kind.COps{cotile} <- getsState scops   body <- getsState $ getActorBody aid   fact <- getsState $ (EM.! bfid body) . sfactionD   mtgtMPath <- getsClient $ EM.lookup aid . stargetD+  lvl <- getLevel $ blid body+  let isAmbient pos = Tile.isLit cotile (lvl `at` pos)   str <- case mtgtMPath of-    Just (_, Just (p : q : _, (goal, _))) ->+    Just (_, Just (p : q : _, (goal, _))) | not $ avoidAmbient && isAmbient q ->       -- With no leader, the goal is vague, so permit arbitrary detours.       moveTowards aid p q goal (fleaderMode (gplayer fact) == LeaderNull)     _ -> return reject  -- goal reached@@ -765,7 +844,10 @@ moveTowards aid source target goal relaxed = do   cops@Kind.COps{cotile} <- getsState scops   b <- getsState $ getActorBody aid-  assert (source == bpos b && adjacent source target) skip+  let !_A = assert (source == bpos b+                    `blame` (source, bpos b, aid, b, goal)) ()+      !_B = assert (adjacent source target+                    `blame` (source, target, aid, b, goal)) ()   lvl <- getLevel $ blid b   fact <- getsState $ (EM.! bfid b) . sfactionD   friends <- getsState $ actorList (not . isAtWar fact) $ blid b@@ -816,26 +898,26 @@       tfact <- getsState $ (EM.! bfid b2) . sfactionD       activeItems <- activeItemsClient target       dEnemy <- getsState $ dispEnemy source target activeItems-      if boldpos sb /= tpos -- avoid trivial Displace loops-         && accessible cops lvl spos tpos -- DisplaceAccess-         && (not (isAtWar tfact (bfid sb))-             || dEnemy)  -- DisplaceDying, DisplaceSupported-      then-        return $! Just $ RequestAnyAbility $ ReqDisplace target-      else do+      if boldpos sb == tpos && not (waitedLastTurn sb)  -- avoid Displace loops+         || not (accessible cops lvl spos tpos) -- DisplaceAccess+      then return Nothing+      else if isAtWar tfact (bfid sb) && not dEnemy  -- DisplaceDying, etc.+      then do         wps <- pickWeaponClient source target         case wps of-          [] -> return Nothing-          wp : _ -> return $! Just $ RequestAnyAbility wp+          Nothing -> return Nothing+          Just wp -> return $! Just $ RequestAnyAbility wp+      else do+        return $! Just $ RequestAnyAbility $ ReqDisplace target     ((target, _), _) : _ -> do  -- can be a foe, as well as friend (e.g., proj.)       -- No problem if there are many projectiles at the spot. We just       -- attack the first one.       -- Attacking does not require full access, adjacency is enough.       wps <- pickWeaponClient source target       case wps of-        [] -> return Nothing-        wp : _ -> return $! Just $ RequestAnyAbility wp-    [] -> do  -- move or search or alter+        Nothing -> return Nothing+        Just wp -> return $! Just $ RequestAnyAbility wp+    [] ->  -- move or search or alter       if accessible cops lvl spos tpos then         -- Movement requires full access.         return $! Just $ RequestAnyAbility $ ReqMove dir

@@ -1,8 +1,11 @@+{-# LANGUAGE TupleSections #-} -- | Semantics of most 'ResponseAI' client commands. module Game.LambdaHack.Client.AI.PickActorClient   ( pickActorToMove   ) where +import Control.Applicative+import Control.Arrow import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM@@ -12,13 +15,16 @@  import Game.LambdaHack.Client.AI.ConditionClient import Game.LambdaHack.Client.AI.PickTargetClient+import Game.LambdaHack.Client.BfsClient import Game.LambdaHack.Client.CommonClient import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State+import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Frequency+import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc@@ -31,8 +37,7 @@ import Game.LambdaHack.Content.ModeKind  pickActorToMove :: MonadClient m-                => (ActorId -> (ActorId, Actor)-                    -> m (Maybe ((ActorId, Actor), (Target, PathEtc))))+                => ((ActorId, Actor) -> m (Maybe (Target, PathEtc)))                 -> ActorId                 -> m (ActorId, Actor) pickActorToMove refreshTarget oldAid = do@@ -46,7 +51,7 @@       t = lvl `at` bpos oldBody   mleader <- getsClient _sleader   ours <- getsState $ actorRegularAssocs (== side) arena-  let explore = void $ refreshTarget oldAid (oldAid, oldBody)+  let explore = void $ refreshTarget (oldAid, oldBody)       pickOld = do         if mleader == Just oldAid then explore         else case ftactic $ gplayer fact of@@ -63,16 +68,16 @@                 else do                   -- Copy over the leader's target, if any, or follow his bpos.                   tgtLeader <- do-                    mtgt <- getsClient $ (EM.lookup leader) . stargetD+                    mtgt <- getsClient $ EM.lookup leader . stargetD                     case mtgt of                       Nothing -> return $! TEnemy leader True                       Just (tgtLeader, _) -> return tgtLeader                   modifyClient $ \cli ->-                    cli { sbfsD = EM.delete oldAid (sbfsD cli)+                    cli { sbfsD = invalidateBfs oldAid (sbfsD cli)                         , seps = seps cli + 773 }  -- randomize paths                   mpath <- createPath oldAid tgtLeader-                  let tgtMPath = maybe (tgtLeader, Nothing)-                                       (\(tgt, p) -> (tgt, Just p)) mpath+                  let tgtMPath =+                        maybe (tgtLeader, Nothing) (second Just) mpath                   modifyClient $ \cli ->                     cli {stargetD = EM.alter (const $ Just tgtMPath)                                              oldAid (stargetD cli)}@@ -98,25 +103,35 @@       -- the old leader, if he is among the best candidates       -- (to make the AI appear more human-like and easier to observe).       -- TODO: this also takes melee into account, but not shooting.-      oursTgt <- fmap catMaybes $ mapM (refreshTarget oldAid) ours-      let actorWeak ((aid, body), _) = do+      let refresh aidBody = do+            mtgt <- refreshTarget aidBody+            return $! (aidBody,) <$> mtgt+      oursTgt <- catMaybes <$> mapM refresh ours+      let actorVulnerable ((aid, body), _) = do             activeItems <- activeItemsClient aid             condMeleeBad <- condMeleeBadM aid             threatDistL <- threatDistList aid-            fleeL <- fleeList False aid-            let condThreatAdj =-                  not $ null $ takeWhile ((== 1) . fst) threatDistL+            (fleeL, _) <- fleeList aid+            let actorMaxSk = sumSkills activeItems+                abInMaxSkill ab = EM.findWithDefault 0 ab actorMaxSk > 0+                condNoUsableWeapon = all (not . isMelee) activeItems+                canMelee = abInMaxSkill AbMelee && not condNoUsableWeapon+                condCanFlee = not (null fleeL)+                condThreatAtHandVeryClose =+                  not $ null $ takeWhile ((<= 2) . fst) threatDistL+                threatAdj = takeWhile ((== 1) . fst) threatDistL+                condThreatAdj = not $ null threatAdj                 condFastThreatAdj =                   any (\(_, (_, b)) ->                          bspeed b activeItems > bspeed body activeItems)-                  $ takeWhile ((== 1) . fst) threatDistL-                condCanFlee = not (null fleeL || condFastThreatAdj)+                      threatAdj                 heavilyDistressed =                   -- Actor hit by a projectile or similarly distressed.                   deltaSerious (bcalmDelta body)-            return $! if condThreatAdj-                      then condMeleeBad && condCanFlee-                      else heavilyDistressed+            return $! if canMelee && condThreatAdj then False+                      else if condThreatAtHandVeryClose+                      then condCanFlee && condMeleeBad && not condFastThreatAdj+                      else heavilyDistressed  -- shot at                         -- TODO: modify when reaction fire is possible           actorHearning (_, (TEnemyPos{}, (_, (_, d)))) | d <= 2 =             return False  -- noise probably due to fleeing target@@ -129,16 +144,25 @@           -- AI has to be prudent and not lightly waste leader for meleeing,           -- even if his target is distant           actorMeleeing ((aid, _), _) = condAnyFoeAdjM aid-      oursWeak <- filterM actorWeak oursTgt-      oursStrong <- filterM (fmap not . actorWeak) oursTgt  -- TODO: partitionM-      oursMeleeing <- filterM actorMeleeing oursStrong-      oursNotMeleeing <- filterM (fmap not . actorMeleeing) oursStrong+          actorMeleeBad ((aid, _), _) = do+            threatDistL <- threatDistList aid+            let condThreatMedium =  -- if foes far, friends may still come+                  not $ null $ takeWhile ((<= 5) . fst) threatDistL+            condMeleeBad <- condMeleeBadM aid+            return $! condThreatMedium && condMeleeBad+      oursVulnerable <- filterM actorVulnerable oursTgt+      oursSafe <- filterM (fmap not . actorVulnerable) oursTgt+        -- TODO: partitionM+      oursMeleeing <- filterM actorMeleeing oursSafe+      oursNotMeleeing <- filterM (fmap not . actorMeleeing) oursSafe       oursHearing <- filterM actorHearning oursNotMeleeing       oursNotHearing <- filterM (fmap not . actorHearning) oursNotMeleeing+      oursMeleeBad <- filterM actorMeleeBad oursNotHearing+      oursNotMeleeBad <- filterM (fmap not . actorMeleeBad) oursNotHearing       let targetTEnemy (_, (TEnemy{}, _)) = True           targetTEnemy (_, (TEnemyPos{}, _)) = True           targetTEnemy _ = False-          (oursTEnemy, oursOther) = partition targetTEnemy oursNotHearing+          (oursTEnemy, oursOther) = partition targetTEnemy oursNotMeleeBad           -- These are not necessarily stuck (perhaps can go around),           -- but their current path is blocked by friends.           targetBlocked our@((_aid, _b), (_tgt, (path, _etc))) =@@ -152,7 +176,8 @@ -- so far we only detect blocked and only in Other mode --             && not (aid == oldAid && waitedLastTurn b time)  -- not stuck -- this only prevents staying stuck-          (oursBlocked, oursPos) = partition targetBlocked oursOther+          (oursBlocked, oursPos) =+            partition targetBlocked $ oursOther ++ oursMeleeBad           -- Lower overhead is better.           overheadOurs :: ((ActorId, Actor), (Target, PathEtc))                        -> (Int, Int, Bool)@@ -160,7 +185,7 @@             if targetTEnemy our then               -- TODO: take weapon, walk and fight speed, etc. into account               ( d + if targetBlocked our then 2 else 0  -- possible delay, hacky-              , - 10 * (fromIntegral $ bhp b `div` (10 * oneM))+              , - 10 * fromIntegral (bhp b `div` (10 * oneM))               , aid /= oldAid )             else               -- Keep proper formation, not too dense, not to sparse.@@ -206,13 +231,13 @@             not (adjacent (bpos b) goal) -- not in melee range already             && goodGeneric our           goodTEnemy our = goodGeneric our-          oursWeakGood = filter goodTEnemy oursWeak+          oursVulnerableGood = filter goodTEnemy oursVulnerable           oursTEnemyGood = filter goodTEnemy oursTEnemy           oursPosGood = filter goodGeneric oursPos           oursMeleeingGood = filter goodGeneric oursMeleeing           oursHearingGood = filter goodTEnemy oursHearing           oursBlockedGood = filter goodGeneric oursBlocked-          candidates = [ sortOurs oursWeakGood+          candidates = [ sortOurs oursVulnerableGood                        , sortOurs oursTEnemyGood                        , sortOurs oursPosGood                        , sortOurs oursMeleeingGood

@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} -- | Let AI pick the best target for an actor. module Game.LambdaHack.Client.AI.PickTargetClient   ( targetStrategy, createPath@@ -5,8 +6,10 @@  import Control.Applicative import Control.Exception.Assert.Sugar+import Control.Monad import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES+import Data.List import Data.Maybe  import Game.LambdaHack.Client.AI.ConditionClient@@ -21,7 +24,7 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction-import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level@@ -39,13 +42,13 @@  -- | AI proposes possible targets for the actor. Never empty. targetStrategy :: forall m. MonadClient m-               => ActorId -> ActorId -> m (Strategy (Target, Maybe PathEtc))-targetStrategy oldLeader aid = do+               => ActorId -> m (Strategy (Target, Maybe PathEtc))+targetStrategy aid = do   cops@Kind.COps{corule, cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops   let stdRuleset = Kind.stdRuleset corule       nearby = rnearby stdRuleset   itemToF <- itemToFullClient-  modifyClient $ \cli -> cli { sbfsD = EM.delete aid (sbfsD cli)+  modifyClient $ \cli -> cli { sbfsD = invalidateBfs aid (sbfsD cli)                              , seps = seps cli + 773 }  -- randomize paths   b <- getsState $ getActorBody aid   activeItems <- activeItemsClient aid@@ -72,24 +75,25 @@                then Just (tgt, (q : rest, (goal, len - 1)))  -- step along path                else Nothing  -- veered off the path         ([p], (goal, _)) -> do-          assert (p == goal `blame` (aid, b, mtgtMPath)) skip+          let !_A = assert (p == goal `blame` (aid, b, mtgtMPath)) ()           if bpos b == p then             Just (tgt, path)  -- goal reached; stay there picking up items           else             Nothing  -- somebody pushed us off the goal; let's target again         ([], _) -> assert `failure` (aid, b, mtgtMPath)     Nothing -> return Nothing  -- no target assigned yet-  assert (not $ bproj b) skip  -- would work, but is probably a bug+  let !_A = assert (not $ bproj b) ()  -- would work, but is probably a bug   fact <- getsState $ (EM.! bfid b) . sfactionD   allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)   dungeon <- getsState sdungeon-  itemD <- getsState sitemD   -- We assume the actor eventually becomes a leader (or has the same   -- set of abilities as the leader, anyway) and set his target accordingly.-  actorSk <- maxActorSkillsClient aid-  condCanProject <- condCanProjectM aid-  condMeleeBad <- condMeleeBadM aid+  let actorMaxSk = sumSkills activeItems+  actorMinSk <- getsState $ actorSkills Nothing aid activeItems+  condCanProject <- condCanProjectM True aid   condHpTooLow <- condHpTooLowM aid+  condEnoughGear <- condEnoughGearM aid+  condMeleeBad <- condMeleeBadM aid   let friendlyFid fid = fid == bfid b || isAllied fact fid   friends <- getsState $ actorRegularList friendlyFid (blid b)   -- TODO: refine all this when some actors specialize in ranged attacks@@ -99,51 +103,72 @@   canEscape <- factionCanEscape (bfid b)   explored <- getsClient sexplored   smellRadius <- sumOrganEqpClient IK.EqpSlotAddSmell aid-  let canSmell = smellRadius > 0+  let condNoUsableWeapon = all (not . isMelee) activeItems+      lidExplored = ES.member (blid b) explored+      allExplored = ES.size explored == EM.size dungeon+      canSmell = smellRadius > 0       meleeNearby | canEscape = nearby `div` 2  -- not aggresive                   | otherwise = nearby       rangedNearby = 2 * meleeNearby-      targetableMelee body =-        chessDist (bpos body) (bpos b) < meleeNearby-        && not condMeleeBad+      -- Don't target nonmoving actors at all if bad melee,+      -- because nonmoving can't be lured nor ambushed.+      -- This is especially important for fences, tower defense actors, etc.+      -- If content gives nonmoving actor loot, this becomes problematic.+      targetableMelee aidE body = do+        activeItemsE <- activeItemsClient aidE+        let actorMaxSkE = sumSkills activeItemsE+            attacksFriends = any (adjacent (bpos body) . bpos) friends+            n = if attacksFriends then rangedNearby else meleeNearby+            nonmoving = EM.findWithDefault 0 AbMove actorMaxSkE <= 0+        return {-keep lazy-} $+           chessDist (bpos body) (bpos b) < n+           && not condNoUsableWeapon+           && EM.findWithDefault 0 AbMelee actorMaxSk > 0+           && not (hpTooLow b activeItems)+           && not (nonmoving && condMeleeBad)       targetableRangedOrSpecial body =         chessDist (bpos body) (bpos b) < rangedNearby-        && (condCanProject-            || hpTooLow body activeItems  -- easy prey-            || any (adjacent (bpos body) . bpos) friends)  -- attacks friends!-      targetableEnemy body =-        targetableMelee body || targetableRangedOrSpecial body-      nearbyFoes = filter (targetableEnemy . snd) allFoes-      unknownId = ouniqGroup "unknown space"-      itemUsefulness iid k =-        fst <$> totalUsefulness cops b activeItems fact (itemToF iid k)-      -- TODO: factor out from here and benGroundItems-      desirableItem iid item k-        | canEscape = itemUsefulness iid k /= Just 0-                        || IK.Precious `elem` jfeature item-        | otherwise =-            let use = itemUsefulness iid k-                -- A hack to prevent monsters from picking up treasure.-                preciousWithoutSlot item2 =-                  IK.Precious `elem` jfeature item2  -- risk from treasure hunters-                  && isNothing (strengthEqpSlot item2)  -- unlikely to be useful-            in use /= Just 0-               && not (isNothing use  -- needs resources to id-                       && preciousWithoutSlot item)+        && condCanProject+      targetableEnemy (aidE, body) = do+        tMelee <- targetableMelee aidE body+        return $! targetableRangedOrSpecial body || tMelee+  nearbyFoes <- filterM targetableEnemy allFoes+  let unknownId = ouniqGroup "unknown space"+      itemUsefulness itemFull =+        fst <$> totalUsefulness cops b activeItems fact itemFull       desirableBag bag = any (\(iid, k) ->-                               desirableItem iid (itemD EM.! iid) k)-                         $ EM.assocs bag+        let itemFull = itemToF iid k+            use = itemUsefulness itemFull+        in desirableItem canEscape use itemFull) $ EM.assocs bag       desirable (_, (_, Nothing)) = True       desirable (_, (_, Just bag)) = desirableBag bag       -- TODO: make more common when weak ranged foes preferred, etc.       focused = bspeed b activeItems < speedNormal || condHpTooLow+      couldMoveLastTurn =+        let axtorSk = if (fst <$> gleader fact) == Just aid+                      then actorMaxSk+                      else actorMinSk+        in EM.findWithDefault 0 AbMove axtorSk > 0+      isStuck = waitedLastTurn b && couldMoveLastTurn+      slackTactic = ftactic (gplayer fact) `elem` [TBlock, TRoam, TPatrol]       setPath :: Target -> m (Strategy (Target, Maybe PathEtc))       setPath tgt = do         mpath <- createPath aid tgt-        return $! returN "pickNewTarget"-               $ maybe (tgt, Nothing) (\(t, p) -> (t, Just p)) mpath+        let take5 (TEnemy{}, pgl) =+              (tgt, Just pgl)  -- for projecting, even by roaming actors+            take5 (_, pgl@(path, (goal, _))) =+              if slackTactic then+                -- Best path only followed 5 moves; then straight on.+                let path5 = take 5 path+                    vtgt | bpos b == goal = tgt+                         | otherwise = TVector $ towards (bpos b) goal+                in (vtgt, Just (path5, (last path5, length path5 - 1)))+              else (tgt, Just pgl)+        return $! returN "setPath" $ maybe (tgt, Nothing) take5 mpath       pickNewTarget :: m (Strategy (Target, Maybe PathEtc))       pickNewTarget = do+        -- This is mostly lazy and used between 0 and 3 times below.+        ctriggers <- closestTriggers Nothing aid         -- TODO: for foes, items, etc. consider a few nearby, not just one         cfoes <- closestFoes nearbyFoes aid         case cfoes of@@ -157,65 +182,76 @@                      else return []             case smpos of               [] -> do-                citems <- if EM.findWithDefault 0 AbMoveItem actorSk > 0-                          then closestItems aid-                          else return []-                case filter desirable citems of-                  [] | ftactic (gplayer fact) == TRoam -> do-                    mtgtPrev <- getsClient $ getTarget aid-                    let vOld = bpos b `vectorToFrom` boldpos b-                        v = case (mtgtPrev, isUnit vOld) of-                              (Just (TVector tgtPrev), True) ->-                                if euclidDistSqVector tgtPrev vOld <= 2-                                then tgtPrev-                                else vOld-                              (Just (TVector tgtPrev), False) -> tgtPrev-                              (_, True) -> vOld-                              (_, False) -> Vector 1 1  -- south-east-                        -- Items and smells considered every 5 moves.-                        -- Thanks to sentinels, @path@ is never null.-                        path = trajectoryToPathBounded-                                 lxsize lysize (bpos b) (replicate 5 v)-                    return $! returN "tgt with no playerLeader"-                      ( TVector v-                      , Just (bpos b : path, (last path, length path)) )-                  [] -> do-                    let lidExplored = ES.member (blid b) explored-                    upos <- if lidExplored-                            then return Nothing-                            else closestUnknown aid-                    case upos of-                      Nothing -> do-                        csuspect <- if lidExplored-                                    then return []-                                    else closestSuspect aid-                        case csuspect of-                          [] -> do-                            ctriggers <--                              if EM.findWithDefault 0 AbTrigger actorSk > 0-                              then closestTriggers Nothing False aid-                              else return []-                            case ctriggers of+                let ctriggersEarly =+                      if EM.findWithDefault 0 AbTrigger actorMaxSk > 0+                         && condEnoughGear+                      then ctriggers+                      else mzero+                if nullFreq ctriggersEarly then do+                  citems <-+                    if EM.findWithDefault 0 AbMoveItem actorMaxSk > 0+                    then closestItems aid+                    else return []+                  case filter desirable citems of+                    [] -> do+                      let vToTgt v0 = do+                            let vFreq = toFreq "vFreq"+                                        $ (20, v0) : map (1,) moves+                            v <- rndToAction $ frequency vFreq+                            -- Items and smells, etc. considered every 7 moves.+                            let tra = trajectoryToPathBounded+                                        lxsize lysize (bpos b) (replicate 7 v)+                                path = nub $ bpos b : tra+                            return $! returN "tgt with no exploration"+                              ( TVector v+                              , if length path == 1+                                then Nothing+                                else Just (path, (last path, length path - 1)) )+                          vOld = bpos b `vectorToFrom` boldpos b+                          pNew = shiftBounded lxsize lysize (bpos b) vOld+                      if slackTactic && not isStuck+                         && isUnit vOld && bpos b /= pNew+                         && accessible cops lvl (bpos b) pNew+                      then vToTgt vOld+                      else do+                        upos <- if lidExplored+                                then return Nothing+                                else closestUnknown aid+                        case upos of+                          Nothing -> do+                            csuspect <- if lidExplored+                                        then return []+                                        else closestSuspect aid+                            case csuspect of                               [] -> do-                                -- All stones turned, time to win or die.-                                afoes <- closestFoes allFoes aid-                                case afoes of-                                  (_, (aid2, _)) : _ ->-                                    setPath $ TEnemy aid2 False-                                  [] -> do-                                    getDistant <--                                      rndToAction $ oneOf-                                      $ [fmap (: []) . furthestKnown]-                                        ++ [ closestTriggers Nothing True-                                           | EM.size dungeon > 1 ]-                                    kpos <- getDistant aid-                                    case kpos of-                                      [] -> return reject-                                      p : _ -> setPath $ TPoint (blid b) p+                                let ctriggersMiddle =+                                      if EM.findWithDefault 0 AbTrigger+                                                            actorMaxSk > 0+                                         && not allExplored+                                      then ctriggers+                                      else mzero+                                if nullFreq ctriggersMiddle then do+                                  -- All stones turned, time to win or die.+                                  afoes <- closestFoes allFoes aid+                                  case afoes of+                                    (_, (aid2, _)) : _ ->+                                      setPath $ TEnemy aid2 False+                                    [] -> do+                                      if nullFreq ctriggers then do+                                        furthest <- furthestKnown aid+                                        setPath $ TPoint (blid b) furthest+                                      else do+                                        p <- rndToAction $ frequency ctriggers+                                        setPath $ TPoint (blid b) p+                                else do+                                  p <- rndToAction $ frequency ctriggers+                                  setPath $ TPoint (blid b) p                               p : _ -> setPath $ TPoint (blid b) p-                          p : _ -> setPath $ TPoint (blid b) p-                      Just p -> setPath $ TPoint (blid b) p-                  (_, (p, _)) : _ -> setPath $ TPoint (blid b) p+                          Just p -> setPath $ TPoint (blid b) p+                    (_, (p, _)) : _ -> setPath $ TPoint (blid b) p+                else do+                  p <- rndToAction $ frequency ctriggers+                  setPath $ TPoint (blid b) p               (_, (p, _)) : _ -> setPath $ TPoint (blid b) p       tellOthersNothingHere pos = do         let f (tgt, _) = case tgt of@@ -250,21 +286,21 @@                         (oldTgt, Just ( bpos b : path                                       , (p, fromMaybe (assert `failure` mpath)                                             $ accessBfs bfs p) ))-        TEnemyPos _ lid p permit ->+        TEnemyPos _ lid p permit           -- Chase last position even if foe hides or dies,           -- to find his companions, loot, etc.-          if lid /= blid b  -- wrong level-             || chessDist (bpos b) p >= nearby  -- too far and not visible-             || permit  -- never follow a friend more than 1 step-          then pickNewTarget-          else if p == bpos b-               then tellOthersNothingHere p-               else return $! returN "TEnemyPos" (oldTgt, Just updatedPath)+          | lid /= blid b  -- wrong level+            || chessDist (bpos b) p >= nearby  -- too far and not visible+            || permit  -- never follow a friend more than 1 step+            -> pickNewTarget+          | p == bpos b -> tellOthersNothingHere p+          | otherwise ->+              return $! returN "TEnemyPos" (oldTgt, Just updatedPath)         _ | not $ null nearbyFoes ->           pickNewTarget  -- prefer close foes to anything         TPoint lid pos -> do-          let allExplored = ES.size explored == EM.size dungeon           bag <- getsState $ getCBag $ CFloor lid pos+          let t = lvl `at` pos           if lid /= blid b  -- wrong level              -- Below we check the target could not be picked again in              -- pickNewTarget, and only in this case it is invalidated.@@ -272,16 +308,18 @@              -- shows up) and not changed all the time mid-route              -- to equally interesting, but perhaps a bit closer targets,              -- most probably already targeted by other actors.-             || (EM.findWithDefault 0 AbMoveItem actorSk <= 0  -- closestItems-                 || not (desirableBag bag))-                && (not canSmell  -- closestSmell-                    || pos == bpos b  -- in case server resends deleted smell+             ||+               (EM.findWithDefault 0 AbMoveItem actorMaxSk <= 0+                || not (desirableBag bag))  -- closestItems+               &&+               (pos == bpos b+                || (not canSmell  -- closestSmell                     || let sml = EM.findWithDefault timeZero pos (lsmell lvl)                        in sml <= ltime lvl)-                && let t = lvl `at` pos-                   in if ES.notMember lid explored+                   && if not lidExplored                       then t /= unknownId  -- closestUnknown                            && not (Tile.isSuspect cotile t)  -- closestSuspect+                           && not (condEnoughGear && Tile.isStair cotile t)                       else  -- closestTriggers                         -- Try to kill that very last enemy for his loot before                         -- leaving the level or dungeon.@@ -293,21 +331,16 @@                            -- We don't determine if the stairs are interesting                            -- (this changes with time), but allow the actor                            -- to reach them and then retarget, unless he can't-                           -- trigger them in the first place.-                           && (EM.findWithDefault 0 AbTrigger actorSk <= 0-                               || pos == bpos b+                           -- trigger them at all.+                           && (EM.findWithDefault 0 AbTrigger actorMaxSk <= 0                                || not (Tile.isStair cotile t))                            -- The remaining case is furthestKnown. This is                            -- always an unimportant target, so we forget it                            -- if the actor is stuck (waits, though could move;                            -- or has zeroed individual moving skill,                            -- but then should change targets often anyway).-                           && let isStuck =-                                    waitedLastTurn b-                                    && canMoveFact fact (oldLeader == aid)-                              in pos == bpos b-                                 || isStuck-                                 || not allExplored+                           && (isStuck+                               || not allExplored))           then pickNewTarget           else return $! returN "TPoint" (oldTgt, Just updatedPath)         TVector{} | len > 1 ->@@ -324,6 +357,8 @@   mpos <- aidTgtToPos aid (blid b) (Just tgt)   case mpos of     Nothing -> return Nothing+-- TODO: for now, an extra turn at target is needed, e.g., to pick up items+--  Just p | p == bpos b -> return Nothing     Just p -> do       (bfs, mpath) <- getCacheBfsAndPath aid p       return $! case mpath of

@@ -3,9 +3,8 @@   ( totalUsefulness, effectToBenefit   ) where -import qualified Control.Monad.State as St+import Control.Applicative import qualified Data.EnumMap.Strict as EM-import Data.Maybe  import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState@@ -28,73 +27,86 @@   let dungeonDweller = not $ fcanEscape $ gplayer fact   in case eff of     IK.NoEffect _ -> 0-    IK.Hurt d -> -(min 99 $ round (10 * Dice.meanDice d))-    IK.Burn p -> -15 * p           -- usually splash damage, etc.-    IK.Explode _ -> -10+    IK.Hurt d -> -(min 100 $ 10 * Dice.meanDice d)+    IK.Burn d -> -(min 150 $ 15 * Dice.meanDice d)+                   -- often splash damage, etc.+    IK.Explode _ -> 0  -- depends on explosion     IK.RefillHP p ->       let hpMax = sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems       in if p > 0-         then 1 + 10 * min p (fromIntegral $ (xM hpMax - bhp b) `divUp` oneM)-         else max (-99) (10 * p)+         -- TODO: when picking up, always deem valuable; when drinking, only if+         -- HP not maxxed.+         then 10 * min p (max 0 $ fromIntegral+                          $ (xM hpMax - bhp b) `divUp` oneM)+         else max (-99) (11 * p)     IK.OverfillHP p ->       let hpMax = sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems       in if p > 0-         then 2 + 10 * min p (fromIntegral $ (xM hpMax - bhp b) `divUp` oneM)-         else max (-99) (10 * p)+         then 11 * min p (max 1 $ fromIntegral+                          $ (xM hpMax - bhp b) `divUp` oneM)+         else max (-99) (11 * p)     IK.RefillCalm p ->       let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems       in if p > 0-         then 1 + min p (fromIntegral $ (xM calmMax - bcalm b) `divUp` oneM)+         then min p (max 0 $ fromIntegral+                     $ (xM calmMax - bcalm b) `divUp` oneM)          else max (-20) p     IK.OverfillCalm p ->       let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems       in if p > 0-         then 2 + min p (fromIntegral $ (xM calmMax - bcalm b) `divUp` oneM)+         then min p (max 1 $ fromIntegral+                     $ (xM calmMax - bcalm b) `divUp` oneM)          else max (-20) p     IK.Dominate -> -200     IK.Impress -> -10-    IK.CallFriend d -> round $ 20 * Dice.meanDice d-    IK.Summon{} | dungeonDweller -> 1 -- probably summons friends or crazies-    IK.Summon{} -> 0                  -- probably generates enemies-    IK.Ascend{} -> 1               -- change levels sensibly, in teams-    IK.Escape{} -> 10000           -- AI wants to win; spawners to guard-    IK.Paralyze d ->  round $ -20 * Dice.meanDice d-    IK.InsertMove d -> round $ 50 * Dice.meanDice d+    IK.CallFriend d -> 100 * Dice.meanDice d+    IK.Summon _ d | dungeonDweller ->+      -- Probably summons friends or crazies.+      -- TODO: should be Negative, to use Calm of enemy, but also positive+      -- to use with own Calm, if needed.+      50 * Dice.meanDice d+    IK.Summon{} -> 0      -- probably generates enemies+    IK.Ascend{} -> 1      -- low, to only change levels sensibly, in teams+                          -- TODO: use if low HP and enemies at hand+    IK.Escape{} -> 10000  -- AI wants to win; spawners to guard+    IK.Paralyze d -> -20 * Dice.meanDice d+    IK.InsertMove d -> 50 * Dice.meanDice d     IK.Teleport d ->-      let p = round $ Dice.meanDice d-      in if p <= 9 then 10  -- blink to shoot at foe-         else if p <= 19 then 1  -- neither escape nor repositioning-         else -5 * p  -- get rid of the foe+      let p = Dice.meanDice d+      in if p <= 8  -- blink to shoot at foe+            && dungeonDweller  -- non-dwellers have to explore and escape ASAP+         then 1+         else -p  -- get rid of the foe     IK.CreateItem COrgan grp _ ->  -- TODO: use the timeout       let (total, count) = organBenefit grp cops b       in total `divUp` count  -- average over all matching grp; rarities ignored-    IK.CreateItem _ _ _ -> 30+    IK.CreateItem{} -> 30  -- TODO     IK.DropItem COrgan grp True ->  -- calculated for future use, general pickup       let (total, _) = organBenefit grp cops b       in - total  -- sum over all matching grp; simplification: rarities ignored     IK.DropItem _ _ False -> -15     IK.DropItem _ _ True -> -30-    IK.PolyItem _ -> 0  -- AI would loop-    IK.Identify _ -> 1  -- not higher, or AI would loop+    IK.PolyItem -> 0  -- AI can't estimate item desirability vs average+    IK.Identify -> 0  -- AI doesn't know how to use     IK.SendFlying _ -> -10  -- but useful on self sometimes, too     IK.PushActor _ -> -10  -- but useful on self sometimes, too     IK.PullActor _ -> -10     IK.DropBestWeapon -> -50     IK.ActivateInv ' ' -> -100     IK.ActivateInv _ -> -50-    IK.ApplyPerfume -> -10+    IK.ApplyPerfume -> 0  -- depends on the smell sense of friends and foes     IK.OneOf _ -> 1  -- usually a mixed blessing, but slightly beneficial     IK.OnSmash _ -> -10-    IK.Recharging e -> effectToBenefit cops b activeItems fact e-                           `divUp` 3  -- TODO: use Timeout+    IK.Recharging e ->+      -- Used, e.g., in @periodicBens@, which takes timeout into account, too.+      effectToBenefit cops b activeItems fact e     IK.Temporary _ -> 0  -- TODO: calculating this for "temporary conditions" takes forever organBenefit :: GroupName ItemKind -> Kind.COps -> Actor -> (Int, Int) organBenefit t cops@Kind.COps{coitem=Kind.Ops{ofoldrGroup}} b =-  let travA x = St.evalState (IK.aspectTrav x (return . round . Dice.meanDice)) ()-      f p _ kind (sacc, pacc) =-        let paspect asp = p * aspectToBenefit cops b (travA asp)+  let f p _ kind (sacc, pacc) =+        let paspect asp = p * aspectToBenefit cops b (Dice.meanDice <$> asp)         in ( sacc + sum (map paspect $ IK.iaspects kind)            , pacc + p )   in ofoldrGroup t f (0, 0)@@ -103,18 +115,19 @@ aspectToBenefit :: Kind.COps -> Actor -> IK.Aspect Int -> Int aspectToBenefit _cops _b asp =   case asp of+    IK.Unique{} -> 0     IK.Periodic{} -> 0     IK.Timeout{} -> 0-    IK.AddMaxHP p -> p * 10-    IK.AddMaxCalm p -> p `divUp` 2-    IK.AddSpeed p -> p * 10000-    IK.AddSkills m -> 5 * sum (EM.elems m)-    IK.AddHurtMelee p -> p `divUp` 3+    IK.AddHurtMelee p -> p     IK.AddHurtRanged p -> p `divUp` 5  -- TODO: should be summed with damage     IK.AddArmorMelee p -> p `divUp` 5     IK.AddArmorRanged p -> p `divUp` 10+    IK.AddMaxHP p -> p+    IK.AddMaxCalm p -> p `div` 5+    IK.AddSpeed p -> p * 10000+    IK.AddSkills m -> 5 * sum (EM.elems m)     IK.AddSight p -> p * 10-    IK.AddSmell p -> p * 2+    IK.AddSmell p -> p * 10     IK.AddLight p -> p * 10  -- | Determine the total benefit from having an item in eqp or inv,@@ -134,26 +147,25 @@                 Just timeout ->                   map (\eff -> eff * 10 `divUp` timeout) periodicEffBens             selfBens = aspBens ++ periodicBens-            eqpSum = if not (null selfBens) && minimum selfBens < -10-                                            && maximum selfBens > 10-                     then 0  -- significant mixed blessings out of AI control-                     else sum selfBens+            selfSum = sum selfBens+            mixedBlessing =+              not (null selfBens)+              && (selfSum > 0 && minimum selfBens < -10+                  || selfSum < 0 && maximum selfBens > 10)             effSum = sum effBens-            isWeapon =-              isJust (strengthFromEqpSlot IK.EqpSlotWeapon itemFull)-            totalSum = if goesIntoInv $ itemBase itemFull-                       then effSum-                       else if isWeapon && effSum < 0-                            then - effSum + eqpSum-                            else eqpSum+            isWeapon = isMeleeEqp itemFull+            totalSum+              | isWeapon && effSum < 0 = - effSum + selfSum+              | goesIntoInv itemFull = effSum+              | mixedBlessing =+                  0  -- significant mixed blessings out of AI control+              | otherwise = selfSum  -- if the weapon heals the enemy, it+                                     -- won't be used but can be equipped         in (totalSum, effSum)   in case itemDisco itemFull of     Just ItemDisco{itemAE=Just ItemAspectEffect{jaspects, jeffects}} ->       Just $ ben jeffects jaspects     Just ItemDisco{itemKind=IK.ItemKind{iaspects, ieffects}} ->-      let travA x =-            St.evalState (IK.aspectTrav x (return . round . Dice.meanDice))-                         ()-          jaspects = map travA iaspects+      let jaspects = map (fmap Dice.meanDice) iaspects       in Just $ ben ieffects jaspects     _ -> Nothing

@@ -1,4 +1,4 @@-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveFoldable, DeriveTraversable, TupleSections #-} -- | AI strategies to direct actors not controlled directly by human players. -- No operation in this module involves the 'State' or 'Action' type. module Game.LambdaHack.Client.AI.Strategy@@ -8,8 +8,10 @@  import Control.Applicative import Control.Monad+import Data.Foldable (Foldable) import Data.Maybe import Data.Text (Text)+import Data.Traversable (Traversable)  import Game.LambdaHack.Common.Frequency as Frequency import Game.LambdaHack.Common.Msg@@ -17,7 +19,7 @@ -- | A strategy is a choice of (non-empty) frequency tables -- of possible actions. newtype Strategy a = Strategy { runStrategy :: [Frequency a] }-  deriving Show+  deriving (Show, Foldable, Traversable)  -- | Strategy is a monad. TODO: Can we write this as a monad transformer? instance Monad Strategy where@@ -98,6 +100,7 @@ returN :: Text -> a -> Strategy a returN name x = Strategy $ return $! uniformFreq name [x] +-- TODO: express with traverse? mapStrategyM :: Monad m => (a -> m (Maybe b)) -> Strategy a -> m (Strategy b) mapStrategyM f s = do   let mapFreq freq = do

@@ -1,10 +1,10 @@ {-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} -- | Breadth first search algorithms. module Game.LambdaHack.Client.Bfs-  ( -- * Public API-    BfsDistance, MoveLegal(..), apartBfs+  ( BfsDistance, MoveLegal(..), apartBfs   , fillBfs, findPathBfs, accessBfs #ifdef EXPOSE_INTERNAL+    -- * Internal operations   , minKnownBfs #endif   ) where@@ -33,11 +33,16 @@ minKnownBfs = toEnum $ (1 + fromEnum (maxBound :: BfsDistance)) `div` 2  -- | The distance value that denote no legal path between points.+-- The next value is the minimal distance value assigned to paths+-- that don't enter any unknown tiles. apartBfs :: BfsDistance apartBfs = pred minKnownBfs --- TODO: costly; peephole optimize, optmize BFS, don't call so often+-- TODO: costly; use a ring buffer instead of the lists, don't call so often -- | Fill out the given BFS array.+-- Unsafe @PointArray@ operations are OK here, because the intermediate+-- values of the vector don't leak anywhere outside nor are kept unevaluated+-- and so they can't be overwritten by the unsafe side-effect. fillBfs :: (Point -> Point -> MoveLegal)  -- ^ is a move from known tile legal         -> (Point -> Point -> Bool)       -- ^ is a move from unknown legal         -> Point                          -- ^ starting position@@ -71,7 +76,7 @@                   (mvsK, mvsU) = foldl' fKnown ([], []) moves                   upd = zip mvsK (repeat distance)                         ++ zip mvsU (repeat distCompl)-                  !a3 = a2 PointArray.// upd+                  !a3 = PointArray.unsafeUpdateA a2 upd               in (mvsK ++ succK2, mvsU ++ succU2, a3)             processUnknown (succU2, a2) pos =               let fUnknown lU move =@@ -83,18 +88,16 @@                        else lU                   mvsU = foldl' fUnknown [] moves                   upd = zip mvsU (repeat distCompl)-                  !a3 = a2 PointArray.// upd+                  !a3 = PointArray.unsafeUpdateA a2 upd               in (mvsU ++ succU2, a3)             (succU4, !a4) = foldl' processUnknown ([], a) predU             (succK6, succU6, !a6) = foldl' processKnown ([], succU4, a4) predK-        in if null succK6 && null succU6-           then a6  -- no more dungeon positions to check-           else if distance == predMaxKnownBfs  -- wasting one Known slot-                then a6  -- too far-                else bfs (succ distance) succK6 succU6 a6-  in PointArray.forceA  -- no more modifications of this array-     $ bfs (succ minKnownBfs) [origin] []-           (aInitial PointArray.// [(origin, minKnownBfs)])+        in if null succK6 && null succU6  -- no more dungeon positions to check+              || distance == predMaxKnownBfs  -- wasting one Known slot+           then a6  -- too far+           else bfs (succ distance) succK6 succU6 a6+  in bfs (succ minKnownBfs) [origin] []+         (PointArray.unsafeUpdateA aInitial [(origin, minKnownBfs)])  -- TODO: Use http://harablog.wordpress.com/2011/09/07/jump-point-search/ -- to determine a few really different paths and compare them,

@@ -1,11 +1,12 @@ {-# LANGUAGE CPP, TupleSections #-} -- | Breadth first search and realted algorithms using the client monad. module Game.LambdaHack.Client.BfsClient-  ( getCacheBfsAndPath, getCacheBfs, accessCacheBfs+  ( invalidateBfs, getCacheBfsAndPath, getCacheBfs, accessCacheBfs   , unexploredDepth, closestUnknown, closestSuspect, closestSmell, furthestKnown   , closestTriggers, closestItems, closestFoes   ) where +import Control.Applicative import Control.Arrow ((&&&)) import Control.Exception.Assert.Sugar import Control.Monad@@ -22,7 +23,10 @@ import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState+import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.MonadStateRead@@ -32,8 +36,20 @@ import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time+import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.TileKind (TileKind) +invalidateBfs :: ActorId+              -> EM.EnumMap ActorId+                   ( Bool, PointArray.Array BfsDistance+                   , Point, Int, Maybe [Point])+              -> EM.EnumMap ActorId+                   ( Bool, PointArray.Array BfsDistance+                   , Point, Int, Maybe [Point])+invalidateBfs =+  EM.adjust+    (\(_, bfs, target, seps, mpath) -> (False, bfs, target, seps, mpath))+ -- | Get cached BFS data and path or, if not stored, generate, -- store and return. Due to laziness, they are not calculated until needed. getCacheBfsAndPath :: forall m. MonadClient m@@ -49,19 +65,29 @@       pathAndStore bfs = do         let mpath = findPathBfs isEnterable passUnknown origin target seps bfs         modifyClient $ \cli ->-          cli {sbfsD = EM.insert aid (bfs, target, seps, mpath) (sbfsD cli)}+          cli {sbfsD = EM.insert aid (True, bfs, target, seps, mpath)+                                 (sbfsD cli)}         return (bfs, mpath)   mbfs <- getsClient $ EM.lookup aid . sbfsD   case mbfs of-    Just (bfs, targetOld, sepsOld, mpath)+    Just (True, bfs, targetOld, sepsOld, mpath)       -- TODO: hack: in screensavers this is not always ensured, so check here:       | bfs PointArray.! bpos b == succ apartBfs ->       if targetOld == target && sepsOld == seps       then return (bfs, mpath)       else pathAndStore bfs     _ -> do+      -- Reduce the number of pointers to @bfsInvalid@, to help @safeSetA@.+      modifyClient $ \cli -> cli {sbfsD = EM.delete aid $ sbfsD cli}       Level{lxsize, lysize} <- getLevel $ blid b-      let vInitial = PointArray.replicateA lxsize lysize apartBfs+      let vInitial = case mbfs of+            Just (_, bfsInvalid, _, _, _) ->  -- TODO: we should verify size+              -- We need to use the safe set, because previous values+              -- of the BFS array for the actor can be stuck unevaluated+              -- in thunks and we are not allowed to overwrite them.+              PointArray.safeSetA apartBfs bfsInvalid+            _ ->+              PointArray.replicateA lxsize lysize apartBfs           bfs = fillBfs isEnterable passUnknown origin vInitial       pathAndStore bfs @@ -70,8 +96,8 @@ getCacheBfs aid = do   mbfs <- getsClient $ EM.lookup aid . sbfsD   case mbfs of-    Just (bfs, _, _, _) -> return bfs-    Nothing -> fmap fst $ getCacheBfsAndPath aid (Point 0 0)+    Just (True, bfs, _, _, _) -> return bfs+    _ -> fst <$> getCacheBfsAndPath aid (Point 0 0)  condBFS :: MonadClient m         => ActorId@@ -86,15 +112,22 @@   -- to reset BFS after leader changes, but it would still lead to   -- wasted movement if, e.g., non-leaders move but only leaders open doors   -- and leader change is very rare.-  actorSk <- maxActorSkillsClient aid+  activeItems <- activeItemsClient aid+  let actorMaxSk = sumSkills activeItems   lvl <- getLevel $ blid b+  smarkSuspect <- getsClient smarkSuspect+  fact <- getsState $ (EM.! bfid b) . sfactionD+  let underAI = isAIFact fact+      enterSuspect = smarkSuspect || underAI+      isPassable | enterSuspect = Tile.isPassable+                 | otherwise = Tile.isPassableNoSuspect   -- We treat doors as an open tile and don't add an extra step for opening   -- the doors, because other actors open and use them, too,   -- so it's amortized. We treat unknown tiles specially.   let unknownId = ouniqGroup "unknown space"       chAccess = checkAccess cops lvl-      canOpenDoors = EM.findWithDefault 0 Ability.AbAlter actorSk > 0-      chDoorAccess = if canOpenDoors then [checkDoorAccess cops lvl] else []+      canOpenDoors = EM.findWithDefault 0 Ability.AbAlter actorMaxSk > 0+      chDoorAccess = [checkDoorAccess cops lvl | canOpenDoors]       conditions = catMaybes $ chAccess : chDoorAccess       -- Legality of move from a known tile, assuming doors freely openable.       isEnterable :: Point -> Point -> MoveLegal@@ -107,7 +140,7 @@            then if not (Tile.isSuspect cotile st) && allOK                 then MoveToUnknown                 else MoveBlocked-           else if Tile.isPassable cotile tt+           else if isPassable cotile tt                    && not (Tile.isChangeable cotile st)  -- takes time to change                    && allOK                 then MoveToOpen@@ -144,20 +177,25 @@ -- | Closest reachable unknown tile position, if any. closestUnknown :: MonadClient m => ActorId -> m (Maybe Point) closestUnknown aid = do+  body <- getsState $ getActorBody aid+  lvl@Level{lxsize, lysize} <- getLevel $ blid body   bfs <- getCacheBfs aid-  getMinIndex <- rndToAction $ oneOf [ PointArray.minIndexA-                                     , PointArray.minLastIndexA ]-  let closestPos = getMinIndex bfs-      dist = bfs PointArray.! closestPos+  let closestPoss = PointArray.minIndexesA bfs+      dist = bfs PointArray.! head closestPoss   if dist >= apartBfs then do-    body <- getsState $ getActorBody aid-    lvl <- getLevel $ blid body     when (lclear lvl == lseen lvl) $ do  -- explored fully, mark it once for all-      assert (lclear lvl >= lseen lvl) skip+      let !_A = assert (lclear lvl >= lseen lvl) ()       modifyClient $ \cli ->         cli {sexplored = ES.insert (blid body) (sexplored cli)}     return Nothing-  else return $ Just closestPos+  else do+    let unknownAround p =+          let vic = vicinity lxsize lysize p+              posUnknown pos = bfs PointArray.! pos < apartBfs+              vicUnknown = filter posUnknown vic+          in length vicUnknown+        cmp = comparing unknownAround+    return $ Just $ maximumBy cmp closestPoss  -- TODO: this is costly, because target has to be changed every -- turn when walking along trail. But inverting the sort and going@@ -209,53 +247,71 @@ -- TODO: We assume linear dungeon in @unexploredD@, -- because otherwise we'd need to calculate shortest paths in a graph, etc. -- | Closest (wrt paths) triggerable open tiles.--- The second argument can ever be true only if there's--- no escape from the dungeon.-closestTriggers :: MonadClient m => Maybe Bool -> Bool -> ActorId -> m [Point]-closestTriggers onlyDir exploredToo aid = do+-- The level the actor is on is either explored or the actor already+-- has a weapon equipped, so no need to explore further, he tries to find+-- enemies on other levels.+closestTriggers :: MonadClient m => Maybe Bool -> ActorId -> m (Frequency Point)+closestTriggers onlyDir aid = do   Kind.COps{cotile} <- getsState scops   body <- getsState $ getActorBody aid+  explored <- getsClient sexplored   let lid = blid body   lvl <- getLevel lid   dungeon <- getsState sdungeon-  explored <- getsClient sexplored+  let escape = any (not . null . lescape) $ EM.elems dungeon   unexploredD <- unexploredDepth   let allExplored = ES.size explored == EM.size dungeon+      -- If lid not explored, aid equips a weapon and so can leave level.+      lidExplored = ES.member (blid body) explored       f :: [(Int, Point)] -> Point -> Kind.Id TileKind -> [(Int, Point)]       f acc p t =         if Tile.isWalkable cotile t && not (null $ Tile.causeEffects cotile t)-        then if exploredToo-             then (1, p) : acc  -- direction irrelevant-             else case Tile.ascendTo cotile t of-               [] ->-                 -- Escape (or guard) after exploring, for high score, etc.-                 if allExplored then (1, p) : acc else acc-               l ->-                 let g k = k > 0-                           && onlyDir /= Just False-                           && unexploredD 1 lid-                           ||-                           k < 0-                           && onlyDir /= Just True-                           && unexploredD (-1) lid+        then case Tile.ascendTo cotile t of+          [] ->+            -- Escape (or guard) only after exploring, for high score, etc.+            if isNothing onlyDir && allExplored+            then (9999999, p) : acc  -- all from that level congregate here+            else acc+          l ->+            if not escape && allExplored+            -- Direction irrelevant; wander randomly.+            then map (,p) l ++ acc+            else let g k =+                       let easier = signum k /= signum (fromEnum lid)+                           unexpForth = unexploredD (signum k) lid+                           unexpBack = unexploredD (- signum k) lid+                           aiCond = if unexpForth+                                    then easier+                                         || not unexpBack && lidExplored+                                    else not unexpBack && lidExplored+                                         && (null $ lescape lvl)+                       in maybe aiCond (\d -> d == (k > 0)) onlyDir                  in map (,p) (filter g l) ++ acc         else acc-  let triggersAll = PointArray.ifoldlA f [] $ ltile lvl+      triggersAll = PointArray.ifoldlA f [] $ ltile lvl       -- Don't target stairs under the actor. Most of the time they       -- are blocked and stay so, so we seek other stairs, if any.-      -- If no other stairs in this direction, let's wait here.-      triggers | length triggersAll > 1 =-                 filter ((/= bpos body) . snd) triggersAll-               | otherwise = triggersAll-  case triggers of-    [] -> return []-    _ -> do-      bfs <- getCacheBfs aid+      -- If no other stairs in this direction, let's wait here,+      -- unless the actor has just returned via the very stairs.+      triggers = filter ((/= bpos body) . snd) triggersAll+  bfs <- getCacheBfs aid+  return $ case triggers of  -- keep lazy+    [] -> mzero+    _ | isNothing onlyDir && not escape && allExplored ->+      -- Distance also irrelevant, to ensure random wandering.+      toFreq "closestTriggers when allExplored" triggers+    _ ->       -- Prefer stairs to easier levels.-      let mix (k, p) dist = ((abs (fromEnum lid + k), dist), p)-          ds = mapMaybe (\(k, p) -> fmap (mix (k, p)) (accessBfs bfs p))-                        triggers-      return $! map snd $ sortBy (comparing fst) ds+      -- If exactly one escape, these stairs will all be in one direction.+      let mix (k, p) dist =+            let easier = signum k /= signum (fromEnum lid)+                depthDelta = if easier then 2 else 1+                distDelta = fromEnum (maxBound :: BfsDistance)+                            - fromEnum apartBfs+                            - dist+            in (depthDelta * distDelta * distDelta, p)+          ds = mapMaybe (\(k, p) -> mix (k, p) <$> accessBfs bfs p) triggers+      in toFreq "closestTriggers" ds  unexploredDepth :: MonadClient m => m (Int -> LevelId -> Bool) unexploredDepth = do@@ -263,14 +319,15 @@   explored <- getsClient sexplored   let allExplored = ES.size explored == EM.size dungeon       unexploredD p =-        let unex lid = allExplored && lescape (dungeon EM.! lid)+        let unex lid = allExplored+                       && (not $ null $ lescape $ dungeon EM.! lid)                        || ES.notMember lid explored                        || unexploredD p lid         in any unex . ascendInBranch dungeon p   return unexploredD  -- | Closest (wrt paths) items and changeable tiles (e.g., item caches).-closestItems :: MonadClient m => ActorId -> m ([(Int, (Point, Maybe ItemBag))])+closestItems :: MonadClient m => ActorId -> m [(Int, (Point, Maybe ItemBag))] closestItems aid = do   Kind.COps{cotile} <- getsState scops   body <- getsState $ getActorBody aid@@ -291,7 +348,7 @@ -- | Closest (wrt paths) enemy actors. closestFoes :: MonadClient m             => [(ActorId, Actor)] -> ActorId -> m [(Int, (ActorId, Actor))]-closestFoes foes aid = do+closestFoes foes aid =   case foes of     [] -> return []     _ -> do

@@ -3,16 +3,15 @@ module Game.LambdaHack.Client.CommonClient   ( getPerFid, aidTgtToPos, aidTgtAims, makeLine   , partAidLeader, partActorLeader, partPronounLeader-  , actorSkillsClient, maxActorSkillsClient-  , updateItemSlot, fullAssocsClient, activeItemsClient-  , itemToFullClient, pickWeaponClient, sumOrganEqpClient, getModeClient+  , actorSkillsClient, updateItemSlot, fullAssocsClient, activeItemsClient+  , itemToFullClient, pickWeaponClient, sumOrganEqpClient   ) where +import Control.Applicative import Control.Exception.Assert.Sugar+import Control.Monad import qualified Data.EnumMap.Strict as EM-import qualified Data.IntMap.Strict as IM import Data.Maybe-import Data.Text (Text) import Data.Tuple import qualified NLP.Miniutter.English as MU @@ -22,7 +21,6 @@ import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest@@ -30,21 +28,22 @@ import Game.LambdaHack.Common.Level import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead+import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ModeKind+import qualified Game.LambdaHack.Content.ItemKind as IK  -- | Get the current perception of a client. getPerFid :: MonadClient m => LevelId -> m Perception getPerFid lid = do   fper <- getsClient sfper-  return $! fromMaybe (assert `failure` "no perception at given level"-                              `twith` (lid, fper))-                      $ EM.lookup lid fper+  let assFail = assert `failure` "no perception at given level"+                       `twith` (lid, fper)+  return $! EM.findWithDefault assFail lid fper  -- | The part of speech describing the actor or "you" if a leader -- of the client's faction. The actor may be not present in the dungeon.@@ -107,23 +106,37 @@ -- because the target actor can be obscured by a glass wall -- or be out of sight range, but in weapon range. aidTgtAims :: MonadClient m-           => ActorId -> LevelId -> Maybe Target -> m (Either Text Int)+           => ActorId -> LevelId -> Maybe Target -> m (Either Msg Int) aidTgtAims aid lidV tgt = do-  oldEps <- getsClient seps+  let findNewEps onlyFirst pos = do+        oldEps <- getsClient seps+        b <- getsState $ getActorBody aid+        mnewEps <- makeLine onlyFirst b pos oldEps+        case mnewEps of+          Just newEps -> return $ Right newEps+          Nothing ->+            return $ Left+                   $ if onlyFirst then "aiming blocked at the first step"+                     else "aiming line to the opponent blocked somewhere"   case tgt of     Just (TEnemy a _) -> do       body <- getsState $ getActorBody a       let pos = bpos body+      if blid body == lidV+      then findNewEps False pos+      else return $ Left "selected opponent not on this level"+    Just TEnemyPos{} -> return $ Left "selected opponent not visible"+    Just (TPoint lid pos) ->+      if lid == lidV+      then findNewEps True pos+      else return $ Left "selected position not on this level"+    Just (TVector v) -> do       b <- getsState $ getActorBody aid-      if blid b == lidV then do-        mnewEps <- makeLine b pos oldEps-        case mnewEps of-          Just newEps -> return $ Right newEps-          Nothing -> return $ Left "aiming line to the opponent blocked"-      else return $ Left "target opponent not on this level"-    Just TEnemyPos{} -> return $ Left "target opponent not visible"-    Just TPoint{} -> return $ Right oldEps-    Just TVector{} -> return $ Right oldEps+      Level{lxsize, lysize} <- getLevel lidV+      let shifted = shiftBounded lxsize lysize (bpos b) v+      if shifted == bpos b && v /= Vector 0 0+      then return $ Left "selected translation is void"+      else findNewEps True shifted     Nothing -> do       scursor <- getsClient scursor       aidTgtAims aid lidV $ Just scursor@@ -132,8 +145,8 @@ -- an actor or obstacle. Starts searching with the given eps and returns -- the first found eps for which the number reaches the distance between -- actor and target position, or Nothing if none can be found.-makeLine :: MonadClient m => Actor -> Point -> Int -> m (Maybe Int)-makeLine body fpos epsOld = do+makeLine :: MonadClient m => Bool -> Actor -> Point -> Int -> m (Maybe Int)+makeLine onlyFirst body fpos epsOld = do   cops@Kind.COps{cotile=Kind.Ops{ouniqGroup}} <- getsState scops   lvl@Level{lxsize, lysize} <- getLevel (blid body)   bs <- getsState $ filter (not . bproj)@@ -147,53 +160,64 @@               noActor p = all ((/= p) . bpos) bs || p == fpos               accessU = all noActor blDist                         && all (uncurry $ accessibleUnknown cops lvl) blZip+              accessFirst | not onlyFirst = False+                          | otherwise =+                all noActor (take 1 blDist)+                && all (uncurry $ accessibleUnknown cops lvl) (take 1 blZip)               nUnknown = length $ filter ((== unknownId) . (lvl `at`)) blDist-          in if accessU then - nUnknown else minBound+          in if accessU then - nUnknown+             else if accessFirst then -10000+             else minBound         Nothing -> assert `failure` (body, fpos, epsOld)-      tryLines curEps (acc, _) | curEps >= epsOld + dist = acc+      tryLines curEps (acc, _) | curEps == epsOld + dist = acc       tryLines curEps (acc, bestScore) =         let curScore = calcScore curEps             newAcc = if curScore > bestScore                      then (Just curEps, curScore)                      else (acc, bestScore)         in tryLines (curEps + 1) newAcc-  return $! if dist <= 1-            then Nothing  -- ProjectBlockActor, ProjectAimOnself-            else tryLines epsOld (Nothing, minBound)+  return $! if dist <= 0 then Nothing  -- ProjectAimOnself+            else if calcScore epsOld > minBound then Just epsOld  -- keep old+            else tryLines (epsOld + 1) (Nothing, minBound)  -- generate best  actorSkillsClient :: MonadClient m => ActorId -> m Ability.Skills actorSkillsClient aid = do   activeItems <- activeItemsClient aid+  body <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid body) . sfactionD+  side <- getsClient sside   -- Newest Leader in _sleader, not yet in sfactionD.-  mleader <- getsClient _sleader+  mleader1 <- if side == bfid body then getsClient _sleader else return Nothing+  let mleader2 = fst <$> gleader fact+      mleader = mleader1 `mplus` mleader2   getsState $ actorSkills mleader aid activeItems -maxActorSkillsClient :: MonadClient m-                     => ActorId -> m Ability.Skills-maxActorSkillsClient aid = do-  activeItems <- activeItemsClient aid-  getsState $ maxActorSkills aid activeItems--updateItemSlot :: MonadClient m => Maybe ActorId -> ItemId -> m ()-updateItemSlot maid iid = do-  slots@(letterSlots, numberSlots) <- getsClient sslots-  case ( lookup iid $ map swap $ EM.assocs letterSlots-       , lookup iid $ map swap $ IM.assocs numberSlots ) of-    (Nothing, Nothing) -> do+updateItemSlot :: MonadClient m+               => CStore -> Maybe ActorId -> ItemId -> m SlotChar+updateItemSlot store maid iid = do+  slots@(itemSlots, organSlots) <- getsClient sslots+  let onlyOrgans = store == COrgan+      lSlots = if onlyOrgans then organSlots else itemSlots+      incrementPrefix m l iid2 = EM.insert l iid2 $+        case EM.lookup l m of+          Nothing -> m+          Just iidOld ->+            let lNew = SlotChar (slotPrefix l + 1) (slotChar l)+            in incrementPrefix m lNew iidOld+  case lookup iid $ map swap $ EM.assocs lSlots of+    Nothing -> do       side <- getsClient sside       item <- getsState $ getItemBody iid       lastSlot <- getsClient slastSlot       mb <- maybe (return Nothing) (fmap Just . getsState . getActorBody) maid-      el <- getsState $ assignSlot item side mb slots lastSlot-      case el of-        Left l ->-          modifyClient $ \cli ->-            cli { sslots = (EM.insert l iid letterSlots, numberSlots)-                , slastSlot = max l (slastSlot cli) }-        Right l ->-          modifyClient $ \cli ->-            cli { sslots = (letterSlots, IM.insert l iid numberSlots) }-    _ -> return ()  -- slot already assigned; a letter or a number+      l <- getsState $ assignSlot store item side mb slots lastSlot+      let newSlots | onlyOrgans = ( itemSlots+                                  , incrementPrefix organSlots l iid )+                   | otherwise =  ( incrementPrefix itemSlots l iid+                                  , organSlots )+      modifyClient $ \cli -> cli {sslots = newSlots}+      return l+    Just l -> return l  -- slot already assigned; a letter or a number  fullAssocsClient :: MonadClient m                  => ActorId -> [CStore] -> m [(ItemId, ItemFull)]@@ -221,37 +245,33 @@ -- Client has to choose the weapon based on its partial knowledge, -- because if server chose it, it would leak item discovery information. pickWeaponClient :: MonadClient m-                 => ActorId -> ActorId -> m [RequestTimed Ability.AbMelee]+                 => ActorId -> ActorId+                 -> m (Maybe (RequestTimed 'Ability.AbMelee)) pickWeaponClient source target = do   eqpAssocs <- fullAssocsClient source [CEqp]   bodyAssocs <- fullAssocsClient source [COrgan]   actorSk <- actorSkillsClient source   sb <- getsState $ getActorBody source+  localTime <- getsState $ getLocalTime (blid sb)   let allAssocs = eqpAssocs ++ bodyAssocs       calm10 = calmEnough10 sb $ map snd allAssocs       forced = assert (not $ bproj sb) False-      legalPrecious = either (const False) id . permittedPrecious calm10 forced-      strongest = strongestSlotNoFilter IK.EqpSlotWeapon allAssocs-      strongestLegal = filter (legalPrecious . snd . snd) strongest-  case strongestLegal of-    _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> return []-    [] -> return []+      permitted = permittedPrecious calm10 forced+      preferredPrecious = either (const False) id . permitted+      strongest = strongestMelee True localTime allAssocs+      strongestPreferred = filter (preferredPrecious . snd . snd) strongest+  case strongestPreferred of+    _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> return Nothing+    [] -> return Nothing     iis@((maxS, _) : _) -> do       let maxIis = map snd $ takeWhile ((== maxS) . fst) iis-      -- TODO: pick the item according to the frequency of its kind.       (iid, _) <- rndToAction $ oneOf maxIis       -- Prefer COrgan, to hint to the player to trash the equivalent CEqp item.       let cstore = if isJust (lookup iid bodyAssocs) then COrgan else CEqp-      return $! [ReqMelee target iid cstore]+      return $ Just $ ReqMelee target iid cstore  sumOrganEqpClient :: MonadClient m                   => IK.EqpSlot -> ActorId -> m Int sumOrganEqpClient eqpSlot aid = do   activeItems <- activeItemsClient aid   return $! sumSlotNoFilter eqpSlot activeItems--getModeClient :: MonadClient m => m ModeKind-getModeClient = do-  Kind.COps{comode=Kind.Ops{okind, ouniqGroup}} <- getsState scops-  t <- getsClient sgameMode-  return $! okind $ ouniqGroup t

@@ -10,7 +10,6 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import Data.Maybe-import qualified Data.Text as T import qualified NLP.Miniutter.English as MU  import Game.LambdaHack.Atomic@@ -28,11 +27,9 @@ import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Perception-import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Content.ItemKind (ItemKind)-import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.TileKind as TK  -- * RespUpdAtomicAI@@ -42,15 +39,6 @@ -- of commands kept for each command received. cmdAtomicFilterCli :: MonadClient m => UpdAtomic -> m [UpdAtomic] cmdAtomicFilterCli cmd = case cmd of-  UpdMoveActor aid _ toP -> do-    cmdSml <- deleteSmell aid toP-    return $ [cmd] ++ cmdSml-  UpdDisplaceActor source target -> do-    bs <- getsState $ getActorBody source-    bt <- getsState $ getActorBody target-    cmdSource <- deleteSmell source (bpos bt)-    cmdTarget <- deleteSmell target (bpos bs)-    return $ [cmd] ++ cmdSource ++ cmdTarget   UpdAlterTile lid p fromTile toTile -> do     Kind.COps{cotile=Kind.Ops{okind}} <- getsState scops     lvl <- getLevel lid@@ -66,7 +54,7 @@         let subject = ""  -- a hack, we we don't handle adverbs well             verb = "turn into"             msg = makeSentence [ "the", MU.Text $ TK.tname $ okind t-                               , "at position", MU.Text $ T.pack $ show p+                               , "at position", MU.Text $ tshow p                                , "suddenly"  -- adverb                                , MU.SubjectVerbSg subject verb                                , MU.AW $ MU.Text $ TK.tname $ okind toTile ]@@ -91,9 +79,7 @@   UpdLearnSecrets aid fromS _toS -> do     b <- getsState $ getActorBody aid     lvl <- getLevel $ blid b-    return $! if lsecret lvl == fromS-              then [cmd]  -- secrets revealed now-              else []  -- secrets already revealed previously+    return $! [cmd | lsecret lvl == fromS]  -- secrets not revealed previously   UpdSpotTile lid ts -> do     Kind.COps{cotile} <- getsState scops     lvl <- getLevel lid@@ -107,17 +93,7 @@                                  || t /= Tile.hideAs cotile tClient)         newTs = filter notKnown ts     return $! if null newTs then [] else [UpdSpotTile lid newTs]-  UpdAlterSmell lid p fromSm _toSm -> do-    lvl <- getLevel lid-    let msml = EM.lookup p $ lsmell lvl-    return $ if msml /= fromSm then-               -- Revert to the server smell before server command executes.-               -- This is needed due to our hacky removal of traversed smells-               -- in @deleteSmell@.-               [UpdAlterSmell lid p msml fromSm, cmd]-             else-               [cmd]-  UpdDiscover lid p iid _ seed -> do+  UpdDiscover c iid _ seed -> do     itemD <- getsState sitemD     case EM.lookup iid itemD of       Nothing -> return []@@ -128,9 +104,9 @@             discoEffect <- getsClient sdiscoEffect             if iid `EM.member` discoEffect               then return []-              else return [UpdDiscoverSeed lid p iid seed]+              else return [UpdDiscoverSeed c iid seed]           else return [cmd]-  UpdCover lid p iid ik _ -> do+  UpdCover c iid ik _ -> do     itemD <- getsState sitemD     case EM.lookup iid itemD of       Nothing -> return []@@ -142,8 +118,8 @@             discoEffect <- getsClient sdiscoEffect             if iid `EM.notMember` discoEffect               then return [cmd]-              else return [UpdCoverKind lid p iid ik]-  UpdDiscoverKind _ _ iid _ -> do+              else return [UpdCoverKind c iid ik]+  UpdDiscoverKind _ iid _ -> do     itemD <- getsState sitemD     case EM.lookup iid itemD of       Nothing -> return []@@ -152,7 +128,7 @@         if jkindIx item `EM.notMember` discoKind         then return []         else return [cmd]-  UpdCoverKind _ _ iid _ -> do+  UpdCoverKind _ iid _ -> do     itemD <- getsState sitemD     case EM.lookup iid itemD of       Nothing -> return []@@ -161,7 +137,7 @@         if jkindIx item `EM.notMember` discoKind         then return []         else return [cmd]-  UpdDiscoverSeed _ _ iid _ -> do+  UpdDiscoverSeed _ iid _ -> do     itemD <- getsState sitemD     case EM.lookup iid itemD of       Nothing -> return []@@ -174,7 +150,7 @@           if iid `EM.member` discoEffect             then return []             else return [cmd]-  UpdCoverSeed _ _ iid _ -> do+  UpdCoverSeed _ iid _ -> do     itemD <- getsState sitemD     case EM.lookup iid itemD of       Nothing -> return []@@ -234,29 +210,18 @@     -- TODO: these assertions are probably expensive     psActor <- mapM posUpdAtomic outActor     -- Verify that we forget only previously seen actors.-    assert (allB seenOld psActor) skip+    let !_A = assert (allB seenOld psActor) ()     -- Verify that we forget only currently invisible actors.-    assert (allB (not . seenNew) psActor) skip+    let !_A = assert (allB (not . seenNew) psActor) ()     let inTileSmell = inFloor ++ inEmbed ++ inSmell     psItemSmell <- mapM posUpdAtomic inTileSmell     -- Verify that we forget only previously invisible items and smell.-    assert (allB (not . seenOld) psItemSmell) skip+    let !_A = assert (allB (not . seenOld) psItemSmell) ()     -- Verify that we forget only currently seen items and smell.-    assert (allB seenNew psItemSmell) skip+    let !_A = assert (allB seenNew psItemSmell) ()     return $! cmd : outActor ++ inTileSmell   _ -> return [cmd] -deleteSmell :: MonadClient m => ActorId -> Point -> m [UpdAtomic]-deleteSmell aid pos = do-  b <- getsState $ getActorBody aid-  smellRadius <- sumOrganEqpClient IK.EqpSlotAddSmell aid-  if smellRadius <= 0 then return []-  else do-    lvl <- getLevel $ blid b-    let msml = EM.lookup pos $ lsmell lvl-    return $-      maybe [] (\sml -> [UpdAlterSmell (blid b) pos (Just sml) Nothing]) msml- -- | Effect of atomic actions on client state is calculated -- in the global state before the command is executed. cmdAtomicSemCli :: MonadClient m => UpdAtomic -> m ()@@ -269,9 +234,10 @@     side <- getsClient sside     when (side == fid) $ do       mleader <- getsClient _sleader-      assert (mleader == fmap fst source  -- somebody changed the leader for us-              || mleader == fmap fst target  -- we changed the leader ourselves-              `blame` "unexpected leader" `twith` (cmd, mleader)) skip+      let !_A = assert (mleader == fmap fst source  -- somebody changed the leader for us+                        || mleader == fmap fst target  -- we changed the leader ourselves+                        `blame` "unexpected leader"+                        `twith` (cmd, mleader)) ()       modifyClient $ \cli -> cli {_sleader = fmap fst target}       case target of         Nothing -> return ()@@ -289,18 +255,18 @@       cli { stargetD = case (mtgt, mleader) of               (Just tgt, Just leader) -> EM.singleton leader tgt               _ -> EM.empty }-  UpdDiscover lid p iid ik seed -> do-    discoverKind lid p iid ik-    discoverSeed lid p iid seed-  UpdCover lid p iid ik seed -> do-    coverSeed lid p iid seed-    coverKind lid p iid ik-  UpdDiscoverKind lid p iid ik -> discoverKind lid p iid ik-  UpdCoverKind lid p iid ik -> coverKind lid p iid ik-  UpdDiscoverSeed lid p iid seed -> discoverSeed lid p iid seed-  UpdCoverSeed lid p iid seed -> coverSeed lid p iid seed+  UpdDiscover c iid ik seed -> do+    discoverKind c iid ik+    discoverSeed c iid seed+  UpdCover c iid ik seed -> do+    coverSeed c iid seed+    coverKind c iid ik+  UpdDiscoverKind c iid ik -> discoverKind c iid ik+  UpdCoverKind c iid ik -> coverKind c iid ik+  UpdDiscoverSeed c iid seed -> discoverSeed c iid seed+  UpdCoverSeed c iid seed -> coverSeed c iid seed   UpdPerception lid outPer inPer -> perception lid outPer inPer-  UpdRestart side sdiscoKind sfper _ sdebugCli sgameMode -> do+  UpdRestart side sdiscoKind sfper _ sdebugCli -> do     shistory <- getsClient shistory     sreport <- getsClient sreport     isAI <- getsClient sisAI@@ -309,7 +275,6 @@                   , sfper                   -- , sundo = [UpdAtomic cmd]                   , scurDifficulty = sdifficultyCli sdebugCli-                  , sgameMode                   , sdebugCli }   UpdResume _fid sfper -> modifyClient $ \cli -> cli {sfper}   UpdKillExit _fid -> killExit@@ -368,26 +333,26 @@     modifyClient $ \cli -> cli {sfper = f (sfper cli)}  discoverKind :: MonadClient m-             => LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m ()-discoverKind lid p iid ik = do+             => Container -> ItemId -> Kind.Id ItemKind -> m ()+discoverKind c iid ik = do   item <- getsState $ getItemBody iid   let f Nothing = Just ik       f Just{} = assert `failure` "already discovered"-                        `twith` (lid, p, iid, ik)+                        `twith` (c, iid, ik)   modifyClient $ \cli -> cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)}  coverKind :: MonadClient m-          => LevelId -> Point -> ItemId -> Kind.Id ItemKind -> m ()-coverKind lid p iid ik = do+          => Container -> ItemId -> Kind.Id ItemKind -> m ()+coverKind c iid ik = do   item <- getsState $ getItemBody iid-  let f Nothing = assert `failure` "already covered" `twith` (lid, p, iid, ik)+  let f Nothing = assert `failure` "already covered" `twith` (c, iid, ik)       f (Just ik2) = assert (ik == ik2 `blame` "unexpected covered item kind"                                        `twith` (ik, ik2)) Nothing   modifyClient $ \cli -> cli {sdiscoKind = EM.alter f (jkindIx item) (sdiscoKind cli)}  discoverSeed :: MonadClient m-             => LevelId -> Point -> ItemId -> ItemSeed -> m ()-discoverSeed lid p iid seed = do+             => Container -> ItemId -> ItemSeed -> m ()+discoverSeed c iid seed = do   Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops   discoKind <- getsClient sdiscoKind   item <- getsState $ getItemBody iid@@ -395,18 +360,18 @@   totalDepth <- getsState stotalDepth   case EM.lookup (jkindIx item) discoKind of     Nothing -> assert `failure` "kind not known"-                      `twith` (lid, p, iid, seed)+                      `twith` (c, iid, seed)     Just ik -> do       let kind = okind ik           f Nothing = Just $ seedToAspectsEffects seed kind ldepth totalDepth           f Just{} = assert `failure` "already discovered"-                            `twith` (lid, p, iid, seed)+                            `twith` (c, iid, seed)       modifyClient $ \cli -> cli {sdiscoEffect = EM.alter f iid (sdiscoEffect cli)}  coverSeed :: MonadClient m-          => LevelId -> Point -> ItemId -> ItemSeed -> m ()-coverSeed lid p iid ik = do-  let f Nothing = assert `failure` "already covered" `twith` (lid, p, iid, ik)+          => Container -> ItemId -> ItemSeed -> m ()+coverSeed c iid ik = do+  let f Nothing = assert `failure` "already covered" `twith` (c, iid, ik)       f Just{} = Nothing  -- checking that old and new agree is too much work   modifyClient $ \cli -> cli {sdiscoEffect = EM.alter f iid (sdiscoEffect cli)} 

@@ -4,8 +4,6 @@   ( handleResponseAI, handleResponseUI   ) where -import Control.Exception.Assert.Sugar- import Game.LambdaHack.Atomic import Game.LambdaHack.Client.AI import Game.LambdaHack.Client.HandleAtomicClient@@ -19,8 +17,8 @@  storeUndo :: MonadClient m => CmdAtomic -> m () storeUndo _atomic =-  maybe skip (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli})-    $ Nothing   -- TODO: undoCmdAtomic atomic+  maybe (return ()) (\a -> modifyClient $ \cli -> cli {sundo = a : sundo cli})+    Nothing   -- TODO: undoCmdAtomic atomic  handleResponseAI :: (MonadAtomic m, MonadClientWriteRequest RequestAI m)                  => ResponseAI -> m ()

@@ -6,14 +6,15 @@   , allSlots, slotLabel, slotRange, assignSlot   ) where +import Control.Exception.Assert.Sugar import Data.Binary+import Data.Bits (shiftL, shiftR) import Data.Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import qualified Data.IntMap.Strict as IM import Data.List-import Data.Maybe import Data.Monoid+import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU@@ -25,17 +26,27 @@ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.State -newtype SlotChar = SlotChar {slotChar :: Char}-  deriving (Show, Eq, Binary)+data SlotChar = SlotChar {slotPrefix :: Int, slotChar :: Char}+  deriving (Show, Eq)  instance Ord SlotChar where-  compare x y = compare (fromEnum x) (fromEnum y)+  compare = comparing fromEnum +instance Binary SlotChar where+  put = put . fromEnum+  get = fmap toEnum get+ instance Enum SlotChar where-  fromEnum (SlotChar x) = fromEnum x + if isUpper x then 1000 else 0-  toEnum e = SlotChar $ toEnum $ e - (if e > 1000 then 1000 else 0)+  fromEnum (SlotChar n c) =+    ord c + (if isUpper c then 100 else 0) + shiftL n 8+  toEnum e =+    let n = shiftR e 8+        c0 = e - shiftL n 8+        c100 = c0 - if c0 > 150 then 100 else 0+    in SlotChar n (chr c100) -type ItemSlots = (EM.EnumMap SlotChar ItemId, IM.IntMap ItemId)+type ItemSlots = ( EM.EnumMap SlotChar ItemId+                 , EM.EnumMap SlotChar ItemId )  slotRange :: [SlotChar] -> Text slotRange ls =@@ -58,36 +69,40 @@                                           , slotChar d ]                 | otherwise      = T.pack [slotChar c, '-', slotChar d] -allSlots :: [SlotChar]-allSlots = map SlotChar $ ['a'..'z'] ++ ['A'..'Z']+allSlots :: Int -> [SlotChar]+allSlots n = map (SlotChar n) $ ['a'..'z'] ++ ['A'..'Z'] +allZeroSlots :: [SlotChar]+allZeroSlots = allSlots 0+ -- | Assigns a slot to an item, for inclusion in the inventory or equipment -- of a hero. Tries to to use the requested slot, if any.-assignSlot :: Item -> FactionId -> Maybe Actor -> ItemSlots -> SlotChar-           -> State-           -> Either SlotChar Int-assignSlot item fid mbody (letterSlots, numberSlots) lastSlot s =-  if jsymbol item == '$'-  then Left $ SlotChar '$'-  else case free of-    freeChar : _ -> Left freeChar-    [] -> Right $ head freeNumbers+assignSlot :: CStore -> Item -> FactionId -> Maybe Actor -> ItemSlots+           -> SlotChar -> State+           -> SlotChar+assignSlot store item fid mbody (itemSlots, organSlots) lastSlot s =+  assert (maybe True (\b -> bfid b == fid) mbody)+  $ if jsymbol item == '$'+    then SlotChar 0 '$'+    else head $ fresh ++ free  where-  candidates = take (length allSlots)-               $ drop (1 + fromJust (elemIndex lastSlot allSlots))-               $ cycle allSlots-  onPerson = maybe (sharedAllOwnedFid True fid s)-                   (\body -> sharedAllOwned True body s)+  offset = maybe 0 (+1) (elemIndex lastSlot allZeroSlots)+  onlyOrgans = store == COrgan+  len0 = length allZeroSlots+  candidatesZero = take len0 $ drop offset $ cycle allZeroSlots+  candidates = candidatesZero ++ concat [allSlots n | n <- [1..]]+  onPerson = sharedAllOwnedFid onlyOrgans fid s+  onGround = maybe EM.empty  -- consider floor only under the acting actor+                   (\b -> getCBag (CFloor (blid b) (bpos b)) s)                    mbody-  onGroud = maybe EM.empty-                  (\b -> getCBag (CFloor (blid b) (bpos b)) s)-                  mbody-  inBags = ES.unions $ map EM.keysSet [onPerson, onGroud]-  f l = maybe True (`ES.notMember` inBags) $ EM.lookup l letterSlots+  inBags = ES.unions $ map EM.keysSet $ onPerson : [ onGround | not onlyOrgans]+  lSlots = if onlyOrgans  then organSlots else itemSlots+  f l = maybe True (`ES.notMember` inBags) $ EM.lookup l lSlots   free = filter f candidates-  g l = maybe True (`ES.notMember` inBags) $ IM.lookup l numberSlots-  freeNumbers = filter g [0..]+  g l = l `EM.notMember` lSlots+  fresh = filter g $ take ((slotPrefix lastSlot + 1) * len0) candidates -slotLabel :: Either SlotChar Int -> MU.Part-slotLabel (Left c) = MU.String [slotChar c]-slotLabel Right{} = "0"+slotLabel :: SlotChar -> MU.Part+slotLabel x = MU.String+              $ (if slotPrefix x == 0 then [] else show $ slotPrefix x)+                ++ [slotChar x]

@@ -3,10 +3,11 @@ module Game.LambdaHack.Client.Key   ( Key(..), showKey, handleDir, dirAllKey   , moveBinding, mkKM, keyTranslate-  , Modifier(..), KM(..), showKM-  , escKM, spaceKM, returnKM, pgupKM, pgdnKM+  , Modifier(..), KM(..), toKM, showKM+  , escKM, spaceKM, returnKM, pgupKM, pgdnKM, leftButtonKM, rightButtonKM   ) where +import Control.DeepSeq import Control.Exception.Assert.Sugar import Data.Binary import qualified Data.Char as Char@@ -16,6 +17,7 @@ import Prelude hiding (Left, Right)  import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Vector  -- | Frontend-independent datatype to represent keys.@@ -39,30 +41,45 @@   | Home   | KP !Char      -- ^ a keypad key for a character (digits and operators)   | Char !Char    -- ^ a single printable character+  | LeftButtonPress    -- ^ left mouse button pressed+  | MiddleButtonPress  -- ^ middle mouse button pressed+  | RightButtonPress   -- ^ right mouse button pressed   | Unknown !Text -- ^ an unknown key, registered to warn the user   deriving (Read, Ord, Eq, Generic)  instance Binary Key +instance NFData Key+ -- | Our own encoding of modifiers. Incomplete. data Modifier =     NoModifier+  | Shift   | Control+  | Alt   deriving (Read, Ord, Eq, Generic)  instance Binary Modifier -data KM = KM {modifier :: !Modifier, key :: !Key}+instance NFData Modifier++data KM = KM { key      :: !Key+             , modifier :: !Modifier+             , pointer  :: !Point }   deriving (Read, Ord, Eq, Generic) +instance NFData KM+ instance Show KM where   show = T.unpack . showKM  instance Binary KM +toKM :: Modifier -> Key -> KM+toKM modifier key = KM{pointer=dummyPoint, ..}+ -- Common and terse names for keys. showKey :: Key -> Text-showKey (Char c) = T.singleton c showKey Esc      = "ESC" showKey Return   = "RET" showKey Space    = "SPACE"@@ -81,28 +98,40 @@ showKey Insert   = "INSERT" showKey Delete   = "DELETE" showKey (KP c)   = "KEYPAD_" <> T.singleton c+showKey (Char c) = T.singleton c+showKey LeftButtonPress = "LEFT-BUTTON"+showKey MiddleButtonPress = "MIDDLE-BUTTON"+showKey RightButtonPress = "RIGHT-BUTTON" showKey (Unknown s) = s  -- | Show a key with a modifier, if any. showKM :: KM -> Text+showKM KM{modifier=Shift, key} = "SHIFT-" <> showKey key showKM KM{modifier=Control, key} = "CTRL-" <> showKey key+showKM KM{modifier=Alt, key} = "ALT-" <> showKey key showKM KM{modifier=NoModifier, key} = showKey key  escKM :: KM-escKM = KM {modifier = NoModifier, key = Esc}+escKM = toKM NoModifier Esc  spaceKM :: KM-spaceKM = KM {modifier = NoModifier, key = Space}+spaceKM = toKM NoModifier Space  returnKM :: KM-returnKM = KM {modifier = NoModifier, key = Return}+returnKM = toKM NoModifier Return  pgupKM :: KM-pgupKM = KM {modifier = NoModifier, key = PgUp}+pgupKM = toKM NoModifier PgUp  pgdnKM :: KM-pgdnKM = KM {modifier = NoModifier, key = PgDn}+pgdnKM = toKM NoModifier PgDn +leftButtonKM :: KM+leftButtonKM = toKM NoModifier LeftButtonPress++rightButtonKM :: KM+rightButtonKM = toKM NoModifier RightButtonPress+ dirKeypadKey :: [Key] dirKeypadKey = [Home, Up, PgUp, Right, PgDn, Down, End, Left] @@ -142,7 +171,7 @@ dirRunControl :: [Key] dirRunControl = dirKeypadKey                 ++ dirKeypadShiftKey-                ++ (map Char dirKeypadShiftChar)+                ++ map Char dirKeypadShiftChar  dirAllKey :: Bool -> Bool -> [Key] dirAllKey configVi configLaptop =@@ -164,9 +193,9 @@ moveBinding configVi configLaptop move run =   let assign f (km, dir) = (km, f dir)       mapMove modifier keys =-        map (assign move) (zip (zipWith KM (repeat modifier) keys) moves)+        map (assign move) (zip (map (toKM modifier) keys) $ cycle moves)       mapRun modifier keys =-        map (assign run) (zip (zipWith KM (repeat modifier) keys) moves)+        map (assign run) (zip (map (toKM modifier) keys) $ cycle moves)   in mapMove NoModifier (dirMoveNoModifier configVi configLaptop)      ++ mapRun NoModifier (dirRunNoModifier configVi configLaptop)      ++ mapRun Control dirRunControl@@ -174,12 +203,13 @@ mkKM :: String -> KM mkKM s = let mkKey sk =                case keyTranslate sk of-                 Unknown _ ->-                   assert `failure` "unknown key" `twith` s+                 Unknown _ -> assert `failure` "unknown key" `twith` s                  key -> key          in case s of-           ('C':'T':'R':'L':'-':rest) -> KM {key=mkKey rest, modifier=Control}-           _ -> KM {key=mkKey s, modifier=NoModifier}+           ('S':'H':'I':'F':'T':'-':rest) -> toKM Shift (mkKey rest)+           ('C':'T':'R':'L':'-':rest) -> toKM Control (mkKey rest)+           ('A':'L':'T':'-':rest) -> toKM Alt (mkKey rest)+           _ -> toKM NoModifier (mkKey s)  -- | Translate key from a GTK string description to our internal key type. -- To be used, in particular, for the command bindings and macros@@ -198,7 +228,8 @@ keyTranslate "asterisk"      = Char '*' keyTranslate "KP_Multiply"   = KP '*' keyTranslate "slash"         = Char '/'-keyTranslate "KP_Divide"     = Char '/'+keyTranslate "KP_Divide"     = KP '/'+keyTranslate "bar"           = Char '|' keyTranslate "backslash"     = Char '\\' keyTranslate "underscore"    = Char '_' keyTranslate "minus"         = Char '-'@@ -211,6 +242,9 @@ keyTranslate "braceleft"     = Char '{' keyTranslate "braceright"    = Char '}' keyTranslate "ampersand"     = Char '&'+keyTranslate "at"            = Char '@'+keyTranslate "asciitilde"    = Char '~'+keyTranslate "exclam"        = Char '!' keyTranslate "apostrophe"    = Char '\'' keyTranslate "Escape"        = Esc keyTranslate "Return"        = Return@@ -249,6 +283,9 @@ keyTranslate "Delete"        = Delete keyTranslate "KP_Delete"     = Delete keyTranslate "KP_Enter"      = Return+keyTranslate "LeftButtonPress" = LeftButtonPress+keyTranslate "MiddleButtonPress" = MiddleButtonPress+keyTranslate "RightButtonPress" = RightButtonPress keyTranslate ['K','P','_',c] = KP c keyTranslate [c]             = Char c keyTranslate s               = Unknown $ T.pack s

@@ -9,7 +9,6 @@ import qualified Data.Text as T  import Game.LambdaHack.Atomic-import Game.LambdaHack.Client.CommonClient import Game.LambdaHack.Client.HandleResponseClient import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.ProtocolClient@@ -46,6 +45,7 @@         Nothing -> return ()       return False +-- | The main game loop for an AI client. loopAI :: ( MonadAtomic m           , MonadClientReadResponse ResponseAI m           , MonadClientWriteRequest RequestAI m )@@ -77,6 +77,7 @@     quit <- getsClient squit     unless quit loop +-- | The main game loop for a UI client. loopUI :: ( MonadClientUI m           , MonadAtomic m           , MonadClientReadResponse ResponseUI m@@ -91,7 +92,7 @@   cmd1 <- receiveResponse   case (restored, cmd1) of     (True, RespUpdAtomicUI UpdResume{}) -> do-      mode <- getModeClient+      mode <- getGameMode       msgAdd $ mdesc mode       handleResponseUI cmd1     (True, RespUpdAtomicUI UpdRestart{}) -> do

@@ -11,7 +11,6 @@ import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import qualified Data.IntMap.Strict as IM import Data.Text (Text) import qualified Data.Text as T import qualified NLP.Miniutter.English as MU@@ -36,7 +35,6 @@ import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ModeKind  -- | Client state, belonging to a single faction. -- Some of the data, e.g, the history, carries over@@ -52,7 +50,7 @@   , sexplored    :: !(ES.EnumSet LevelId)                                    -- ^ the set of fully explored levels   , sbfsD        :: !(EM.EnumMap ActorId-                        ( PointArray.Array BfsDistance+                        ( Bool, PointArray.Array BfsDistance                         , Point, Int, Maybe [Point]) )                                    -- ^ pathfinding distances for our actors                                    --   and paths to their targets, if any@@ -69,6 +67,7 @@   , sdiscoEffect :: !DiscoveryEffect  -- ^ remembered effects&Co of items   , sfper        :: !FactionPers   -- ^ faction perception indexed by levels   , srandom      :: !R.StdGen      -- ^ current random generator+  , slastKM      :: !K.KM          -- ^ last issued key command   , slastRecord  :: !LastRecord    -- ^ state of key sequence recording   , slastPlay    :: ![K.KM]        -- ^ state of key sequence playback   , slastLost    :: !(ES.EnumSet ActorId)@@ -85,7 +84,7 @@   , scurDifficulty :: !Int         -- ^ current game difficulty level   , sslots       :: !ItemSlots     -- ^ map from slots to items   , slastSlot    :: !SlotChar      -- ^ last used slot-  , sgameMode    :: !(GroupName ModeKind)  -- ^ current game mode+  , slastStore   :: !CStore        -- ^ last used store   , sescAI       :: !EscAI         -- ^ just canceled AI control with ESC   , sdebugCli    :: !DebugModeCli  -- ^ client debugging mode   }@@ -101,10 +100,10 @@ data RunParams = RunParams   { runLeader  :: !ActorId         -- ^ the original leader from run start   , runMembers :: ![ActorId]       -- ^ the list of actors that take part-  , runDist    :: !Int             -- ^ distance of the run so far-                                   --   (plus one, if multiple runners)+  , runInitial :: !Bool            -- ^ initial run continuation by any+                                   --   run participant, including run leader   , runStopMsg :: !(Maybe Text)    -- ^ message with the next stop reason-  , runInitDir :: !(Maybe Vector)  -- ^ the direction of the initial step+  , runWaiting :: !Int             -- ^ waiting for others to move out of the way   }   deriving (Show) @@ -138,6 +137,7 @@     , sdiscoEffect = EM.empty     , sfper = EM.empty     , srandom = R.mkStdGen 42  -- will be set later+    , slastKM = K.escKM     , slastRecord = ([], [], 0)     , slastPlay = []     , slastLost = ES.empty@@ -150,9 +150,9 @@     , smarkSmell = True     , smarkSuspect = False     , scurDifficulty = difficultyDefault-    , sslots = (EM.empty, IM.empty)-    , slastSlot = SlotChar 'a'-    , sgameMode = "starting"+    , sslots = (EM.empty, EM.empty)+    , slastSlot = SlotChar 0 'Z'+    , slastStore = CInv     , sescAI = EscAINothing     , sdebugCli = defDebugModeCli     }@@ -224,7 +224,7 @@     put scurDifficulty     put sslots     put slastSlot-    put sgameMode+    put slastStore     put sdebugCli  -- TODO: this is overwritten at once   get = do     stgtMode <- get@@ -250,11 +250,12 @@     scurDifficulty <- get     sslots <- get     slastSlot <- get-    sgameMode <- get+    slastStore <- get     sdebugCli <- get     let sbfsD = EM.empty         sfper = EM.empty         srandom = read g+        slastKM = K.escKM         slastRecord = ([], [], 0)         slastPlay = []         slastLost = ES.empty@@ -267,13 +268,13 @@   put RunParams{..} = do     put runLeader     put runMembers-    put runDist+    put runInitial     put runStopMsg-    put runInitDir+    put runWaiting   get = do     runLeader <- get     runMembers <- get-    runDist<- get+    runInitial <- get     runStopMsg <- get-    runInitDir <- get+    runWaiting <- get     return $! RunParams{..}

@@ -13,6 +13,7 @@     -- * Operations exposed for LoopClient   , ColorMode(..), displayMore, msgAdd #ifdef EXPOSE_INTERNAL+    -- * Internal operations   , humanCommand #endif   ) where@@ -28,7 +29,6 @@ import qualified Game.LambdaHack.Client.Key as K import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State-import Game.LambdaHack.Client.UI.Config import Game.LambdaHack.Client.UI.Content.KeyKind import Game.LambdaHack.Client.UI.DisplayAtomicClient import Game.LambdaHack.Client.UI.HandleHumanClient@@ -36,12 +36,13 @@ import Game.LambdaHack.Client.UI.KeyBindings import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.MsgClient-import Game.LambdaHack.Client.UI.RunClient import Game.LambdaHack.Client.UI.StartupFrontendClient import Game.LambdaHack.Client.UI.WidgetClient import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import Game.LambdaHack.Content.ModeKind@@ -52,56 +53,30 @@   side <- getsClient sside   fact <- getsState $ (EM.! side) . sfactionD   let (leader, mtgt) = fromMaybe (assert `failure` fact) $ gleader fact-  srunning <- getsClient srunning-  -- When running, stop if disturbed. If not running, let the human-  -- player issue commands, until any command takes time.-  req <- case srunning of-    Nothing -> humanCommand Nothing-    Just RunParams{runMembers}-      | noRunWithMulti fact && runMembers /= [leader] -> do-      stopRunning-      Config{configRunStopMsgs} <- askConfig-      let msg = if configRunStopMsgs-                then Just $ "Run stop: automatic leader change"-                else Nothing-      humanCommand msg-    Just runParams -> do-      runOutcome <- continueRun runParams-      case runOutcome of-        Left stopMsg -> do-          stopRunning-          Config{configRunStopMsgs} <- askConfig-          let msg = if configRunStopMsgs-                    then Just $ "Run stop:" <+> stopMsg-                    else Nothing-          humanCommand msg-        Right (paramNew, runCmd) -> do-          modifyClient $ \cli -> cli {srunning = Just paramNew}-          displayPush-          return $! anyToUI $ runCmd+  req <- humanCommand   leader2 <- getLeaderUI   mtgt2 <- getsClient $ fmap fst . EM.lookup leader2 . stargetD   if (leader2, mtgt2) /= (leader, mtgt)     then return $! ReqUILeader leader2 mtgt2 req     else return $! req --- | Determine and process the next human player command. The argument is--- the last stop message due to running, if any.-humanCommand :: forall m. MonadClientUI m-             => Maybe Msg -> m RequestUI-humanCommand msgRunStop = do+-- | Let the human player issue commands until any command takes time.+humanCommand :: forall m. MonadClientUI m => m RequestUI+humanCommand = do   -- For human UI we invalidate whole @sbfsD@ at the start of each-  -- UI player input, which is an overkill, but doesn't affects-  -- screensavers, because they are UI, but not human.+  -- UI player input that start a player move, which is an overkill,+  -- but doesn't slow screensavers, because they are UI,+  -- but not human.   modifyClient $ \cli -> cli {sbfsD = EM.empty, slastLost = ES.empty}-  let loop :: Maybe (Bool, Overlay) -> m RequestUI+  let loop :: Either Bool (Maybe Bool, Overlay) -> m RequestUI       loop mover = do         (lastBlank, over) <- case mover of-          Nothing -> do-            -- Display current state if no slideshow or if interrupted.-            sli <- promptToSlideshow ""-            return (False, head . snd $! slideshow sli)-          Just bLast ->+          Left b -> do+            -- Display current state and keys if no slideshow or if interrupted.+            keys <- if b then describeMainKeys else return ""+            sli <- promptToSlideshow keys+            return (Nothing, head . snd $! slideshow sli)+          Right bLast ->             -- (Re-)display the last slide while waiting for the next key.             return bLast         (seqCurrent, seqPrevious, k) <- getsClient slastRecord@@ -112,16 +87,16 @@           _ -> do             let slastRecord = ([], seqCurrent ++ seqPrevious, k - 1)             modifyClient $ \cli -> cli {slastRecord}+        lastPlay <- getsClient slastPlay         km <- getKeyOverlayCommand lastBlank over         -- Messages shown, so update history and reset current report.-        recordHistory+        when (null lastPlay) recordHistory         abortOrCmd <- do           -- Look up the key.           Binding{bcmdMap} <- askBinding-          case M.lookup km bcmdMap of+          case M.lookup km{K.pointer=dummyPoint} bcmdMap of             Just (_, _, cmd) -> do               -- Query and clear the last command key.-              stgtMode <- getsClient stgtMode               modifyClient $ \cli -> cli                 {swaitTimes = if swaitTimes cli > 0                               then - swaitTimes cli@@ -137,11 +112,12 @@                   cmdHumanSem cmd                 _ -> do                   modifyClient $ \cli -> cli {sescAI = EscAINothing}-                  if km == K.escKM && isNothing stgtMode && isJust mover+                  stgtMode <- getsClient stgtMode+                  if km == K.escKM && isNothing stgtMode && isRight mover                   then cmdHumanSem Clear                   else cmdHumanSem cmd             Nothing -> let msgKey = "unknown command <" <> K.showKM km <> ">"-                       in fmap Left $ promptToSlideshow msgKey+                       in failWith msgKey         -- The command was failed or successful and if the latter,         -- possibly took some time.         case abortOrCmd of@@ -154,23 +130,21 @@             -- Analyse the obtained slides.             let (onBlank, sli) = slideshow slides             mLast <- case sli of-              [] -> return Nothing+              [] -> do+                stgtMode <- getsClient stgtMode+                return $ Left $ isJust stgtMode || km == K.escKM               [sLast] ->                 -- Avoid displaying the single slide twice.-                return $ Just (onBlank, sLast)+                return $ Right (onBlank, sLast)               _ -> do                 -- Show, one by one, all slides, awaiting confirmation                 -- for all but the last one (which is displayed twice, BTW).                 -- Note: the code that generates the slides is responsible                 -- for inserting the @more@ prompt.                 go <- getInitConfirms ColorFull [km] slides-                return $! if go then Just (onBlank, last sli) else Nothing+                return $! if go then Right (onBlank, last sli) else Left True             loop mLast-  case msgRunStop of-    Nothing -> loop Nothing-    Just msg -> do-      sli <- promptToSlideshow msg-      loop $ Just (False, head . snd $ slideshow sli)+  loop $ Left False  -- | Client signals to the server that it's still online, flushes frames -- (if needed) and sends some extra info.

@@ -4,7 +4,8 @@   ( SingleFrame(..), decodeLine, encodeLine   , overlayOverlay   , Animation, Frames, renderAnim, restrictAnim-  , twirlSplash, blockHit, blockMiss, deathBody, swapPlaces, fadeout+  , twirlSplash, blockHit, blockMiss, deathBody, actorX+  , swapPlaces, moveProj, fadeout   ) where  import Control.Exception.Assert.Sugar@@ -84,7 +85,7 @@         let fLine y lineOld =               let f l (x, acOld) =                     let pos = Point x y-                        !ac = fromMaybe acOld $ EM.lookup pos am+                        !ac = EM.findWithDefault acOld pos am                     in ac : l               in foldl' f [] (zip [lxsize-1,lxsize-2..0] (reverse lineOld))             sfLevel =  -- fully evaluated inside@@ -93,13 +94,13 @@                  $ foldl' f [] (zip [lysize-1,lysize-2..0]                                 $ reverse $ map decodeLine levelOld)         in Just SingleFrame{..}  -- a thunk within Just-  in Nothing : map (modifyFrame basicFrame) anim ++ [Nothing]+  in map (modifyFrame basicFrame) anim  blank :: Maybe AttrChar blank = Nothing -coloredSymbol :: Color -> Char -> Maybe AttrChar-coloredSymbol color symbol = Just $ AttrChar (Attr color defBG) symbol+cSym :: Color -> Char -> Maybe AttrChar+cSym color symbol = Just $ AttrChar (Attr color defBG) symbol  mzipPairs :: (Point, Point) -> (Maybe AttrChar, Maybe AttrChar)           -> [(Point, AttrChar)]@@ -111,6 +112,13 @@                       -- not the action.                       [mzip (p1, mattr1)] +mzipTriples :: (Point, Point, Point)+            -> (Maybe AttrChar, Maybe AttrChar, Maybe AttrChar)+            -> [(Point, AttrChar)]+mzipTriples (p1, p2, p3) (mattr1, mattr2, mattr3) =+  let mzip (pos, mattr) = fmap (\x -> (pos, x)) mattr+  in catMaybes [mzip (p1, mattr1), mzip (p2, mattr2), mzip (p3, mattr3)]+ restrictAnim :: ES.EnumSet Point -> Animation -> Animation restrictAnim vis (Animation as) =   let f imap =@@ -118,71 +126,122 @@           in if EM.null common then Nothing else Just common   in Animation $ mapMaybe f as +-- TODO: in all but moveProj duplicate first and/or last frame, if required,+-- since they are no longer duplicated in renderAnim+ -- | Attack animation. A part of it also reused for self-damage and healing. twirlSplash :: (Point, Point) -> Color -> Color -> Animation twirlSplash poss c1 c2 = Animation $ map (EM.fromList . mzipPairs poss)-  [ (blank                    , coloredSymbol BrCyan '\'')-  , (blank                    , coloredSymbol BrYellow '^')-  , (coloredSymbol c1      '/', coloredSymbol BrCyan '^')-  , (coloredSymbol c1      '-', blank)-  , (coloredSymbol c1      '\\',blank)-  , (coloredSymbol c1      '|', blank)-  , (coloredSymbol c2      '%', blank)-  , (coloredSymbol c2      '/', blank)+  [ (blank           , cSym BrCyan '\'')+  , (blank           , cSym BrYellow '\'')+  , (blank           , cSym BrYellow '^')+  , (cSym c1      '\\',cSym BrCyan '^')+  , (cSym c1      '|', cSym BrCyan '^')+  , (cSym c1      '%', blank)+  , (cSym c1      '/', blank)+  , (cSym c1      '-', blank)+  , (cSym c1      '\\',blank)+  , (cSym c2      '|', blank)+  , (cSym c2      '%', blank)+  , (cSym c2      '%', blank)+  , (cSym c2      '/', blank)   ]  -- | Attack that hits through a block. blockHit :: (Point, Point) -> Color -> Color -> Animation blockHit poss c1 c2 = Animation $ map (EM.fromList . mzipPairs poss)-  [ (blank                    , coloredSymbol BrCyan '\'')-  , (blank                    , coloredSymbol BrYellow '^')-  , (blank                    , coloredSymbol BrCyan '^')-  , (coloredSymbol BrBlue  '{', coloredSymbol BrYellow '\'')-  , (coloredSymbol BrBlue  '{', blank)-  , (coloredSymbol BrBlue  '}', blank)-  , (coloredSymbol BrBlue  '}', blank)-  , (coloredSymbol c1      '\\',blank)-  , (coloredSymbol c1      '|', blank)-  , (coloredSymbol c2      '%', blank)-  , (coloredSymbol c2      '/', blank)+  [ (blank           , cSym BrCyan '\'')+  , (blank           , cSym BrYellow '\'')+  , (blank           , cSym BrYellow '^')+  , (blank           , cSym BrCyan '^')+  , (cSym BrBlue  '{', cSym BrCyan '\'')+  , (cSym BrBlue  '{', cSym BrYellow '\'')+  , (cSym BrBlue  '{', cSym BrYellow '\'')+  , (cSym BrBlue  '}', blank)+  , (cSym BrBlue  '}', blank)+  , (cSym BrBlue  '}', blank)+  , (cSym c1      '\\',blank)+  , (cSym c1      '|', blank)+  , (cSym c1      '/', blank)+  , (cSym c1      '-', blank)+  , (cSym c2      '\\',blank)+  , (cSym c2      '|', blank)+  , (cSym c2      '/', blank)   ]  -- | Attack that is blocked. blockMiss :: (Point, Point) -> Animation blockMiss poss = Animation $ map (EM.fromList . mzipPairs poss)-  [ (blank                    , coloredSymbol BrCyan '\'')-  , (coloredSymbol BrBlue  '{', coloredSymbol BrYellow '^')-  , (coloredSymbol BrBlue  '{', blank)-  , (coloredSymbol BrBlue  '}', blank)-  , (coloredSymbol Blue    '}', blank)+  [ (blank           , cSym BrCyan '\'')+  , (blank           , cSym BrYellow '^')+  , (cSym BrBlue  '{', cSym BrYellow '\'')+  , (cSym BrBlue  '{', cSym BrCyan '\'')+  , (cSym BrBlue  '{', blank)+  , (cSym BrBlue  '}', blank)+  , (cSym BrBlue  '}', blank)+  , (cSym Blue    '}', blank)+  , (cSym Blue    '}', blank)   ]  -- | Death animation for an organic body. deathBody :: Point -> Animation deathBody pos = Animation $ map (maybe EM.empty (EM.singleton pos))-  [ coloredSymbol BrRed '\\'-  , coloredSymbol BrRed '\\'-  , coloredSymbol BrRed '|'-  , coloredSymbol BrRed '|'-  , coloredSymbol BrRed '%'-  , coloredSymbol BrRed '%'-  , coloredSymbol Red   '%'-  , coloredSymbol Red   '%'-  , coloredSymbol Red   '%'-  , coloredSymbol Red   ';'-  , coloredSymbol Red   ';'-  , coloredSymbol Red   ','+  [ cSym BrRed '\\'+  , cSym BrRed '\\'+  , cSym BrRed '|'+  , cSym BrRed '|'+  , cSym BrRed '%'+  , cSym BrRed '%'+  , cSym BrRed '-'+  , cSym BrRed '-'+  , cSym BrRed '\\'+  , cSym BrRed '\\'+  , cSym BrRed '|'+  , cSym BrRed '|'+  , cSym BrRed '%'+  , cSym BrRed '%'+  , cSym BrRed '%'+  , cSym Red   '%'+  , cSym Red   '%'+  , cSym Red   '%'+  , cSym Red   '%'+  , cSym Red   ';'+  , cSym Red   ';'+  , cSym Red   ','   ] +-- | Mark actor location animation.+actorX :: Point -> Char -> Color.Color -> Animation+actorX pos symbol color = Animation $ map (maybe EM.empty (EM.singleton pos))+  [ cSym BrRed 'X'+  , cSym BrRed 'X'+  , cSym BrRed symbol+  , cSym color symbol+  , cSym color symbol+  , cSym color symbol+  , cSym color symbol+  ]+ -- | Swap-places animation, both hostile and friendly. swapPlaces :: (Point, Point) -> Animation swapPlaces poss = Animation $ map (EM.fromList . mzipPairs poss)-  [ (coloredSymbol BrMagenta 'o', coloredSymbol Magenta   'o')-  , (coloredSymbol BrMagenta 'd', coloredSymbol Magenta   'p')-  , (coloredSymbol Magenta   'p', coloredSymbol BrMagenta 'd')-  , (coloredSymbol Magenta   'o', blank)+  [ (cSym BrMagenta 'o', cSym Magenta   'o')+  , (cSym BrMagenta 'd', cSym Magenta   'p')+  , (cSym BrMagenta '.', cSym Magenta   'p')+  , (cSym Magenta   'p', cSym Magenta   '.')+  , (cSym Magenta   'p', cSym BrMagenta 'd')+  , (cSym Magenta   'p', cSym BrMagenta 'd')+  , (cSym Magenta   'o', blank)   ] +moveProj :: (Point, Point, Point) -> Char -> Color.Color -> Animation+moveProj poss symbol color = Animation $ map (EM.fromList . mzipTriples poss)+  [ (cSym BrBlack '.', cSym color symbol  , cSym color '.')+--  , (cSym BrBlack '.', cSym BrBlack symbol, cSym color symbol)+  , (cSym BrBlack '.', cSym BrBlack '.'   , cSym color symbol)+  , (blank           , cSym BrBlack '.'   , cSym color symbol)+  ]+ fadeout :: Bool -> Bool -> Int -> X -> Y -> Rnd Animation fadeout out topRight step lxsize lysize = do   let xbound = lxsize - 1@@ -213,5 +272,5 @@         return $! EM.fromList l       startN = if out then 3 else 1       fs = [startN, startN + step .. 3 * lxsize `divUp` 4 + 2]-  as <- mapM rollFrame $ if out then fs else reverse fs-  return $! Animation as+  as <- mapM rollFrame fs+  return $! Animation $ if out then as else reverse (EM.empty : as)

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveGeneric, FlexibleContexts #-} -- | Personal game configuration file type definitions. module Game.LambdaHack.Client.UI.Config   ( Config(..), mkConfig, applyConfigToDebug@@ -15,6 +16,7 @@ import Data.Text (Text) import qualified Data.Text as T import Game.LambdaHack.Common.ClientOptions+import GHC.Generics (Generic) import System.Directory import System.FilePath import Text.Read@@ -43,7 +45,7 @@   , configNoAnim      :: !Bool   , configRunStopMsgs :: !Bool   }-  deriving Show+  deriving (Show, Generic)  instance NFData Config @@ -90,8 +92,7 @@ mkConfig Kind.COps{corule} = do   let stdRuleset = Kind.stdRuleset corule       cfgUIName = rcfgUIName stdRuleset-      commentsUIDefault = init $ map (drop 2) $ lines $ rcfgUIDefault stdRuleset  -- TODO: init is a hack until Ini accepts empty files-      sUIDefault = unlines commentsUIDefault+      sUIDefault = rcfgUIDefault stdRuleset       cfgUIDefault = either (assert `failure`) id $ Ini.parse sUIDefault   dataDir <- appDataDir   let userPath = dataDir </> cfgUIName <.> "ini"

@@ -1,6 +1,7 @@ -- | The type of key-command mappings to be used for the UI. module Game.LambdaHack.Client.UI.Content.KeyKind   ( KeyKind(..)+  , macroLeftButtonPress, macroShiftLeftButtonPress   ) where  import qualified Game.LambdaHack.Client.Key as K@@ -11,3 +12,17 @@   { rhumanCommands :: ![(K.KM, ([CmdCategory], HumanCmd))]                                    -- ^ default client UI commands   }++macroLeftButtonPress :: HumanCmd+macroLeftButtonPress =+  Macro "go to pointer for 100 steps"+        [ "ALT-space", "ALT-minus"+        , "SHIFT-MiddleButtonPress", "CTRL-semicolon"+        , "CTRL-period", "V" ]++macroShiftLeftButtonPress :: HumanCmd+macroShiftLeftButtonPress =+  Macro "run collectively to pointer for 100 steps"+        [ "ALT-space"+        , "SHIFT-MiddleButtonPress", "CTRL-colon"+        , "CTRL-period", "V" ]

@@ -5,9 +5,8 @@  import Control.Exception.Assert.Sugar import Control.Monad-import qualified Data.EnumSet as ES import qualified Data.EnumMap.Strict as EM-import qualified Data.IntMap.Strict as IM+import qualified Data.EnumSet as ES import Data.Maybe import Data.Monoid import Data.Tuple@@ -39,6 +38,7 @@ import Game.LambdaHack.Common.Time import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Content.TileKind as TK  -- * RespUpdAtomicUI@@ -57,7 +57,7 @@ -- the client state is modified by the command. displayRespUpdAtomicUI :: MonadClientUI m                        => Bool -> State -> StateClient -> UpdAtomic -> m ()-displayRespUpdAtomicUI verbose _oldState oldStateClient cmd = case cmd of+displayRespUpdAtomicUI verbose oldState oldStateClient cmd = case cmd of   -- Create/destroy actors and items.   UpdCreateActor aid body _ -> createActorUI aid body verbose "appear"   UpdDestroyActor aid body _ -> do@@ -66,41 +66,46 @@     when (bfid body == side && not (bproj body)) stopPlayBack   UpdCreateItem iid _ kit c -> do     case c of-      CActor aid COrgan -> do-        let verb =-              MU.Text $ "become" <+> case fst kit of-                                       1 -> ""-                                       k -> tshow k <> "-fold"-        -- This describes all such items already among organs,-        -- which is useful, because it shows "charging".-        itemAidVerbMU aid verb iid (Left Nothing) COrgan       CActor aid store -> do-        when (store == CGround) $ updateItemSlotSide aid iid-        itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c+        l <- updateItemSlotSide store aid iid+        case store of+          COrgan -> do+            let verb =+                  MU.Text $ "become" <+> case fst kit of+                                           1 -> ""+                                           k -> tshow k <> "-fold"+            -- This describes all such items already among organs,+            -- which is useful, because it shows "charging".+            itemAidVerbMU aid verb iid (Left Nothing) COrgan+          _ -> do+            itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c+            mleader <- getsClient _sleader+            when (Just aid == mleader) $+              modifyClient $ \cli -> cli { slastSlot = l+                                         , slastStore = store }       CEmbed{} -> return ()       CFloor{} -> do-        updateItemSlot Nothing iid+        -- If you want an item to be assigned to @slastSlot@, create it+        -- in @CActor aid CGround@, not in @CFloor@.+        void $ updateItemSlot CGround Nothing iid         itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c-      CTrunk{} -> return ()+      CTrunk{} -> assert `failure` c     stopPlayBack   UpdDestroyItem iid _ kit c -> itemVerbMU iid kit "disappear" c   UpdSpotActor aid body _ -> createActorUI aid body verbose "be spotted"   UpdLoseActor aid body _ ->     destroyActorUI aid body "be missing in action" "be lost" verbose   UpdSpotItem iid _ kit c -> do-    -- We assign slots to all items visible on the floor,-    -- but some of the slots are later on recycled and then-    -- we report spotting the items again.-    (letterSlots, numberSlots) <- getsClient sslots-    case ( lookup iid $ map swap $ EM.assocs letterSlots-         , lookup iid $ map swap $ IM.assocs numberSlots ) of-      (Nothing, Nothing) -> do+    (itemSlots, _) <- getsClient sslots+    case lookup iid $ map swap $ EM.assocs itemSlots of+      Nothing ->  -- never seen or would have a slot         case c of-          CActor aid CGround -> updateItemSlotSide aid iid-          CActor{} -> return ()+          CActor aid store ->+            -- Enemy actor fetching an item from shared stash, most probably.+            void $ updateItemSlotSide store aid iid           CEmbed{} -> return ()           CFloor lid p -> do-            updateItemSlot Nothing iid+            void $ updateItemSlot CGround Nothing iid             scursorOld <- getsClient scursor             case scursorOld of               TEnemy{} -> return ()  -- probably too important to overwrite@@ -109,25 +114,26 @@             itemVerbMU iid kit "be spotted" c             stopPlayBack           CTrunk{} -> return ()-      _ -> return ()  -- seen recently (still has a slot assigned)-  UpdLoseItem{} -> skip+      _ -> return ()  -- seen already (has a slot assigned)+  UpdLoseItem{} -> return ()   -- Move actors and items.-  UpdMoveActor aid _ _ -> lookAtMove aid+  UpdMoveActor aid source target -> moveActor oldState aid source target   UpdWaitActor aid _ -> when verbose $ aidVerbMU aid "wait"   UpdDisplaceActor source target -> displaceActorUI source target-  UpdMoveItem iid k aid c1 c2 -> moveItemUI verbose iid k aid c1 c2+  UpdMoveItem iid k aid c1 c2 -> moveItemUI iid k aid c1 c2   -- Change actor attributes.-  UpdAgeActor{} -> skip-  UpdRefillHP _ 0 -> skip+  UpdAgeActor{} -> return ()+  UpdRefillHP _ 0 -> return ()   UpdRefillHP aid n -> do     when verbose $       aidVerbMU aid $ MU.Text $ (if n > 0 then "heal" else "lose")-                              <+> tshow (abs $ n `divUp` oneM) <> "HP"+                                <+> tshow (abs $ n `divUp` oneM) <> "HP"     mleader <- getsClient _sleader     when (Just aid == mleader) $ do       b <- getsState $ getActorBody aid       hpMax <- sumOrganEqpClient IK.EqpSlotAddMaxHP aid-      when (bhp b == xM hpMax && hpMax > 0) $ do+      when (bhp b >= xM hpMax && hpMax > 0+            && resCurrentTurn (bhpDelta b) > 0) $ do         actorVerbMU aid b "recover your health fully"         stopPlayBack   UpdRefillCalm aid calmDelta ->@@ -141,9 +147,9 @@         when (null closeFoes) $ do  -- obvious where the feeling comes from           aidVerbMU aid "hear something"           msgDuplicateScrap-  UpdOldFidActor{} -> skip-  UpdTrajectory{} -> skip-  UpdColorActor{} -> skip+  UpdFidImpressedActor{} -> return ()+  UpdTrajectory{} -> return ()+  UpdColorActor{} -> return ()   -- Change faction attributes.   UpdQuitFaction fid mbody _ toSt -> quitFactionUI fid mbody toSt   UpdLeadFaction fid (Just (source, _)) (Just (target, _)) -> do@@ -168,7 +174,7 @@           -- TODO: report when server changes spawner's leader;           -- perhaps don't switch _sleader in HandleAtomicClient,           -- compare here and switch here? too hacky? fails for AI?-  UpdLeadFaction{} -> skip+  UpdLeadFaction{} -> return ()   UpdDiplFaction fid1 fid2 _ toDipl -> do     name1 <- getsState $ gname . (EM.! fid1) . sfactionD     name2 <- getsState $ gname . (EM.! fid2) . sfactionD@@ -177,11 +183,11 @@         showDipl Alliance = "allied"         showDipl War = "at war"     msgAdd $ name1 <+> "and" <+> name2 <+> "are now" <+> showDipl toDipl <> "."-  UpdTacticFaction{} -> skip+  UpdTacticFaction{} -> return ()   UpdAutoFaction fid b -> do     side <- getsClient sside     when (fid == side) $ setFrontAutoYes b-  UpdRecordKill{} -> skip+  UpdRecordKill{} -> return ()   -- Alter map.   UpdAlterTile{} -> when verbose $ return ()  -- TODO: door opens   UpdAlterClear _ k -> msgAdd $ if k > 0@@ -203,24 +209,25 @@                            , "a hidden"                            , MU.Text $ TK.tname $ okind toTile ]     msgAdd msg-  UpdLearnSecrets{} -> skip-  UpdSpotTile{} -> skip-  UpdLoseTile{} -> skip-  UpdAlterSmell{} -> skip-  UpdSpotSmell{} -> skip-  UpdLoseSmell{} -> skip+  UpdLearnSecrets{} -> return ()+  UpdSpotTile{} -> return ()+  UpdLoseTile{} -> return ()+  UpdAlterSmell{} -> return ()+  UpdSpotSmell{} -> return ()+  UpdLoseSmell{} -> return ()   -- Assorted.-  UpdTimeItem{} -> skip-  UpdAgeGame{} -> skip-  UpdDiscover lid p iid _ _ -> discover lid p oldStateClient iid-  UpdCover{} -> skip  -- don't spam when doing undo-  UpdDiscoverKind lid p iid _ -> discover lid p oldStateClient iid-  UpdCoverKind{} -> skip  -- don't spam when doing undo-  UpdDiscoverSeed lid p iid _ -> discover lid p oldStateClient iid-  UpdCoverSeed{} -> skip  -- don't spam when doing undo-  UpdPerception{} -> skip-  UpdRestart fid _ _ _ _ _ -> do-    mode <- getModeClient+  UpdTimeItem{} -> return ()+  UpdAgeGame{} -> return ()+  UpdDiscover c iid _ _ -> discover c oldStateClient iid+  UpdCover{} -> return ()  -- don't spam when doing undo+  UpdDiscoverKind c iid _ -> discover c oldStateClient iid+  UpdCoverKind{} -> return ()  -- don't spam when doing undo+  UpdDiscoverSeed c iid _ -> discover c oldStateClient iid+  UpdCoverSeed{} -> return ()  -- don't spam when doing undo+  UpdPerception{} -> return ()+  UpdRestart fid _ _ _ _ -> do+    void $ tryTakeMVarSescMVar  -- clear ESC-pressed from end of previous game+    mode <- getGameMode     msgAdd $ "New game started in" <+> mname mode <+> "mode." <+> mdesc mode     -- TODO: use a vertical animation instead, e.g., roll down,     -- and reveal the first frame of a new game, not blank screen.@@ -228,23 +235,24 @@     when (lengthHistory history > 1) $ fadeOutOrIn False     fact <- getsState $ (EM.! fid) . sfactionD     setFrontAutoYes $ isAIFact fact-  UpdRestartServer{} -> skip+  UpdRestartServer{} -> return ()   UpdResume fid _ -> do     fact <- getsState $ (EM.! fid) . sfactionD     setFrontAutoYes $ isAIFact fact-  UpdResumeServer{} -> skip-  UpdKillExit{} -> skip+  UpdResumeServer{} -> return ()+  UpdKillExit{} -> return ()   UpdWriteSave -> when verbose $ msgAdd "Saving backup."   UpdMsgAll msg -> msgAdd msg   UpdRecordHistory _ -> recordHistory -updateItemSlotSide :: MonadClient m => ActorId -> ItemId -> m ()-updateItemSlotSide aid iid = do+updateItemSlotSide :: MonadClient m+                   => CStore -> ActorId -> ItemId -> m SlotChar+updateItemSlotSide store aid iid = do   side <- getsClient sside   b <- getsState $ getActorBody aid   if bfid b == side-  then updateItemSlot (Just aid) iid-  else updateItemSlot Nothing iid+  then updateItemSlot store (Just aid) iid+  else updateItemSlot store Nothing iid  lookAtMove :: MonadClientUI m => ActorId -> m () lookAtMove aid = do@@ -281,7 +289,7 @@   lid <- getsState $ lidFromC c   localTime <- getsState $ getLocalTime lid   itemToF <- itemToFullClient-  let subject = partItemWs k c lid localTime (itemToF iid kit)+  let subject = partItemWs k (storeFromC c) lid localTime (itemToF iid kit)       msg | k > 1 = makeSentence [MU.SubjectVerb MU.PlEtc MU.Yes subject verb]           | otherwise = makeSentence [MU.SubjectVerbSg subject verb]   msgAdd msg@@ -294,28 +302,28 @@               -> ItemId -> Either (Maybe Int) Int -> CStore               -> m () itemAidVerbMU aid verb iid ek cstore = do-  let c = CActor aid cstore-  bag <- getsState $ getCBag c+  bag <- getsState $ getActorBag aid cstore   -- The item may no longer be in @c@, but it was   case iid `EM.lookup` bag of     Nothing -> assert `failure` (aid, verb, iid, cstore)     Just kit@(k, _) -> do       itemToF <- itemToFullClient-      lid <- getsState $ lidFromC c+      body <- getsState $ getActorBody aid+      let lid = blid body       localTime <- getsState $ getLocalTime lid       subject <- partAidLeader aid       let itemFull = itemToF iid kit           object = case ek of             Left (Just n) ->               assert (n <= k `blame` (aid, verb, iid, cstore))-              $ partItemWs n c lid localTime itemFull+              $ partItemWs n cstore lid localTime itemFull             Left Nothing ->-              let (name, stats) = partItem c lid localTime itemFull+              let (_, name, stats) = partItem cstore lid localTime itemFull               in MU.Phrase [name, stats]             Right n ->               assert (n <= k `blame` (aid, verb, iid, cstore))               $ let itemSecret = itemNoDisco (itemBase itemFull, n)-                    (secretName, secretAE) = partItem c lid localTime itemSecret+                    (_, secretName, secretAE) = partItem cstore lid localTime itemSecret                     name = MU.Phrase [secretName, secretAE]                     nameList = if n == 1                                then ["the", name]@@ -339,18 +347,12 @@ createActorUI :: MonadClientUI m               => ActorId -> Actor -> Bool -> MU.Part -> m () createActorUI aid body verbose verb = do+  mapM_ (\(iid, store) -> void $ updateItemSlotSide store aid iid)+        (getCarriedIidCStore body)   side <- getsClient sside-  -- Don't spam if the actor was already visible (but, e.g., on a tile that is-  -- invisible this turn (in that case move is broken down to lose+spot)-  -- or on a distant tile, via teleport while the observer teleported, too).-  lastLost <- getsClient slastLost-  when (ES.notMember aid lastLost-        && (bfid body /= side-            && not (bproj body) || verbose)) $-    actorVerbMU aid body verb   when (bfid body /= side) $ do     fact <- getsState $ (EM.! bfid body) . sfactionD-    when (not (bproj body) && isAtWar fact side) $ do+    when (not (bproj body) && isAtWar fact side) $       -- Target even if nobody can aim at the enemy. Let's home in on him       -- and then we can aim or melee. We set permit to False, because it's       -- technically very hard to check aimability here, because we are@@ -358,47 +360,62 @@       -- into account.       modifyClient $ \cli -> cli {scursor = TEnemy aid False}     stopPlayBack+  -- Don't spam if the actor was already visible (but, e.g., on a tile that is+  -- invisible this turn (in that case move is broken down to lose+spot)+  -- or on a distant tile, via teleport while the observer teleported, too).+  lastLost <- getsClient slastLost+  when (ES.notMember aid lastLost+        && (not (bproj body) || verbose)) $ do+    actorVerbMU aid body verb+    animFrs <- animate (blid body)+               $ actorX (bpos body) (bsymbol body) (bcolor body)+    displayActorStart body animFrs   lookAtMove aid  destroyActorUI :: MonadClientUI m                => ActorId -> Actor -> MU.Part -> MU.Part -> Bool -> m () destroyActorUI aid body verb verboseVerb verbose = do+  Kind.COps{corule} <- getsState scops   side <- getsClient sside-  if (bfid body == side && bhp body <= 0 && not (bproj body)) then do-    actorVerbMU aid body verb-    void $ displayMore ColorBW ""+  when (bfid body == side) $ do+    let upd = ES.delete aid+    modifyClient $ \cli -> cli {sselected = upd $ sselected cli}+  if bfid body == side && bhp body <= 0 && not (bproj body) then do+    when verbose $ actorVerbMU aid body verb+    let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule+        fid = bfid body+    fact <- getsState $ (EM.! fid) . sfactionD+    actorsAlive <- anyActorsAlive fid (Just aid)+    -- TODO: deduplicate wrt Server+    -- TODO; actually show the --more- prompt, but not between fadeout frames+    unless (fneverEmpty (gplayer fact)+            && (not actorsAlive || firstDeathEnds)) $+      void $ displayMore ColorBW ""   else when verbose $ actorVerbMU aid body verboseVerb   modifyClient $ \cli -> cli {slastLost = ES.insert aid $ slastLost cli} -moveItemUI :: MonadClientUI m-           => Bool -> ItemId -> Int -> ActorId -> CStore -> CStore-           -> m ()-moveItemUI verbose iid k aid cstore1 cstore2 = do-  let verb = verbCStore cstore2-  when (cstore2 == CGround) $ updateItemSlotSide aid iid-  b <- getsState $ getActorBody aid-  fact <- getsState $ (EM.! bfid b) . sfactionD-  let underAI = isAIFact fact-  mleader <- getsClient _sleader-  if (cstore1 == CGround && Just aid == mleader && not underAI) then do-    itemAidVerbMU aid (MU.Text verb) iid (Right k) cstore2-    localTime <- getsState $ getLocalTime (blid b)-    itemToF <- itemToFullClient-    (letterSlots, _) <- getsClient sslots-    let c2 = CActor aid cstore2-    bag <- getsState $ getCBag c2-    let kit@(n, _) = bag EM.! iid-    case lookup iid $ map swap $ EM.assocs letterSlots of-      Just l -> msgAdd $ makePhrase-                  [ "\n"-                  , slotLabel $ Left l-                  , "-"-                  , partItemWs n c2 (blid b) localTime (itemToF iid kit)-                  , "\n" ]-      Nothing -> return ()-  else when (cstore2 /= CGround || verbose) $  -- dropping is silent-    itemAidVerbMU aid (MU.Text verb) iid (Left $ Just k) cstore2+-- TODO: deduplicate wrt Server+anyActorsAlive :: MonadClient m => FactionId -> Maybe ActorId -> m Bool+anyActorsAlive fid maid = do+  fact <- getsState $ (EM.! fid) . sfactionD+  if fleaderMode (gplayer fact) /= LeaderNull+    then return $! isJust $ gleader fact+    else do+      as <- getsState $ fidActorNotProjAssocs fid+      return $! not $ null $ maybe as (\aid -> filter ((/= aid) . fst) as) maid +moveActor :: MonadClientUI m => State -> ActorId -> Point -> Point -> m ()+moveActor oldState aid source target = do+  lookAtMove aid+  body <- getsState $ getActorBody aid+  when (bproj body) $ do+    let oldpos = case EM.lookup aid $ sactorD oldState of+          Nothing -> assert `failure` (sactorD oldState, aid)+          Just b -> boldpos b+    let ps = (oldpos, source, target)+    animFrs <- animate (blid body) $ moveProj ps (bsymbol body) (bcolor body)+    displayActorStart body animFrs+ displaceActorUI :: MonadClientUI m => ActorId -> ActorId -> m () displaceActorUI source target = do   sb <- getsState $ getActorBody source@@ -414,6 +431,37 @@   animFrs <- animate (blid sb) $ swapPlaces ps   displayActorStart sb animFrs +moveItemUI :: MonadClientUI m+           => ItemId -> Int -> ActorId -> CStore -> CStore+           -> m ()+moveItemUI iid k aid cstore1 cstore2 = do+  let verb = verbCStore cstore2+  b <- getsState $ getActorBody aid+  fact <- getsState $ (EM.! bfid b) . sfactionD+  let underAI = isAIFact fact+  mleader <- getsClient _sleader+  bag <- getsState $ getActorBag aid cstore2+  let kit@(n, _) = bag EM.! iid+  itemToF <- itemToFullClient+  (itemSlots, _) <- getsClient sslots+  case lookup iid $ map swap $ EM.assocs itemSlots of+    Just l -> do+      when (Just aid == mleader) $+        modifyClient $ \cli -> cli { slastSlot = l+                                   , slastStore = cstore2 }+      if cstore1 == CGround && Just aid == mleader && not underAI then do+        itemAidVerbMU aid (MU.Text verb) iid (Right k) cstore2+        localTime <- getsState $ getLocalTime (blid b)+        msgAdd $ makePhrase+                   [ "\n"+                   , slotLabel l+                   , "-"+                   , partItemWs n cstore2 (blid b) localTime (itemToF iid kit)+                   , "\n" ]+      else when (not (bproj b) && bhp b > 0) $  -- don't announce death drops+        itemAidVerbMU aid (MU.Text verb) iid (Left $ Just k) cstore2+    Nothing -> assert `failure` (iid, itemToF iid kit)+ quitFactionUI :: MonadClientUI m               => FactionId -> Maybe Actor -> Maybe Status -> m () quitFactionUI fid mbody toSt = do@@ -471,8 +519,7 @@                           <+> moreMsg             if EM.null bag then return (mempty, 0)             else do-              mapM_ (updateItemSlot Nothing) $ EM.keys bag-              io <- itemOverlay (CFloor (blid b) (bpos b)) (blid b) bag+              io <- itemOverlay CGround (blid b) bag               sli <- overlayToSlideshow itemMsg io               return (sli, tot)       (itemSlides, total) <- case mbody of@@ -501,29 +548,33 @@     _ -> return ()  discover :: MonadClientUI m-         => LevelId -> Point -> StateClient -> ItemId -> m ()-discover lid p oldcli iid = do+         => Container -> StateClient -> ItemId -> m ()+discover c oldcli iid = do+  let cstore = storeFromC c+  lid <- getsState $ lidFromC c   cops <- getsState scops   localTime <- getsState $ getLocalTime lid   itemToF <- itemToFullClient-  let itemFull = itemToF iid (1, [])-      c = CFloor lid p-      (knownName, knownAEText) = partItem c lid localTime itemFull+  bag <- getsState $ getCBag c+  let kit = EM.findWithDefault (1, []) iid bag+      itemFull = itemToF iid kit+      knownName = partItemMediumAW cstore lid localTime itemFull       -- Wipe out the whole knowledge of the item to make sure the two names       -- in the message differ even if, e.g., the item is described as       -- "of many effects".       itemSecret = itemNoDisco (itemBase itemFull, itemK itemFull)-      (secretName, secretAEText) = partItem c lid localTime itemSecret+      (_, secretName, secretAEText) = partItem cstore lid localTime itemSecret       msg = makeSentence         [ "the", MU.SubjectVerbSg (MU.Phrase [secretName, secretAEText])                                   "turn out to be"-        , MU.AW $ MU.Phrase [knownName, knownAEText] ]+        , knownName ]       oldItemFull =         itemToFull cops (sdiscoKind oldcli) (sdiscoEffect oldcli)                    iid (itemBase itemFull) (1, [])   -- Compare descriptions of all aspects and effects to determine   -- if the discovery was meaningful to the player.-  when (textAllAE False c itemFull /= textAllAE False c oldItemFull) $+  when (textAllAE 7 False cstore itemFull+        /= textAllAE 7 False cstore oldItemFull) $     msgAdd msg  -- * RespSfxAtomicUI@@ -531,19 +582,21 @@ -- | Display special effects (text, animation) sent to the client. displayRespSfxAtomicUI :: MonadClientUI m => Bool -> SfxAtomic -> m () displayRespSfxAtomicUI verbose sfx = case sfx of-  SfxStrike source target iid b -> strike source target iid b-  SfxRecoil source target _ _ -> do+  SfxStrike source target iid cstore b -> strike source target iid cstore b+  SfxRecoil source target _ _ _ -> do     spart <- partAidLeader source     tpart <- partAidLeader target     msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink away from", tpart]-  SfxProject aid iid cstore ->+  SfxProject aid iid cstore -> do+    setLastSlot aid iid cstore     itemAidVerbMU aid "aim" iid (Left $ Just 1) cstore   SfxCatch aid iid cstore ->     itemAidVerbMU aid "catch" iid (Left $ Just 1) cstore-  SfxActivate aid iid cstore ->-    itemAidVerbMU aid "activate" iid (Left $ Just 1) cstore+  SfxApply aid iid cstore -> do+    setLastSlot aid iid cstore+    itemAidVerbMU aid "apply" iid (Left $ Just 1) cstore   SfxCheck aid iid cstore ->-    itemAidVerbMU aid "deactivate" iid (Left $ Just 1) cstore+    itemAidVerbMU aid "deapply" iid (Left $ Just 1) cstore   SfxTrigger aid _p _feat ->     when verbose $ aidVerbMU aid "trigger"  -- TODO: opens door, etc.   SfxShun aid _p _ ->@@ -552,8 +605,9 @@     b <- getsState $ getActorBody aid     side <- getsClient sside     let fid = bfid b-    if bhp b <= 0 && not (bproj b) || bhp b < 0 then do-      -- We assume the effect is the cause of incapacitation.+    if bhp b <= 0 then do+      -- We assume the effect is the cause of incapacitation, but in case+      -- of projectile, to reduce spam, we verify with @canKill@.       let firstFall | fid == side && bproj b = "fall apart"                     | fid == side = "fall down"                     | bproj b = "break up"@@ -562,35 +616,43 @@                     | fid == side = "be stomped flat"                     | bproj b = "be shattered into little pieces"                     | otherwise = "be reduced to a bloody pulp"-      subject <- partActorLeader aid b-      let deadPreviousTurn p = p < 0-                               && (bhp b <= p && not (bproj b)-                                   || bhp b < p)-          (deadBefore, verbDie) =+          -- Aspect bonuses ignored, so hurtExtra will add variety sometimes.+          deadPreviousTurn dp = bhp b <= dp+          harm2 dp = if deadPreviousTurn dp+                     then (True, Just hurtExtra)+                     else (False, Just firstFall)+          (deadBefore, mverbDie) =             case effect of-              IK.Hurt p | deadPreviousTurn (xM $ Dice.maxDice p) ->-                (True, hurtExtra)-              IK.RefillHP p | deadPreviousTurn (xM p) -> (True, hurtExtra)-              IK.OverfillHP p | deadPreviousTurn (xM p) -> (True, hurtExtra)-              _ -> (False, firstFall)-          msgDie = makeSentence [MU.SubjectVerbSg subject verbDie]-      msgAdd msgDie-      when (fid == side && not (bproj b)) $ do-        animDie <- if deadBefore-                   then animate (blid b)-                        $ twirlSplash (bpos b, bpos b) Color.Red Color.Red-                   else animate (blid b) $ deathBody $ bpos b-        displayActorStart b animDie+              IK.Hurt p -> harm2 (- (xM $ Dice.maxDice p))+              IK.RefillHP p | p < 0 -> harm2 (xM p)+              IK.OverfillHP p | p < 0 -> harm2 (xM p)+              IK.Burn p -> harm2 (- (xM $ Dice.maxDice p))+              _ -> (False, Nothing)+      case mverbDie of+        Nothing -> return ()  -- only brutal effects work on dead/dying actor+        Just verbDie -> do+          subject <- partActorLeader aid b+          let msgDie = makeSentence [MU.SubjectVerbSg subject verbDie]+          msgAdd msgDie+          when (fid == side && not (bproj b)) $ do+            animDie <- if deadBefore+                       then animate (blid b)+                            $ twirlSplash (bpos b, bpos b) Color.Red Color.Red+                       else animate (blid b) $ deathBody $ bpos b+            displayActorStart b animDie     else case effect of         IK.NoEffect t -> msgAdd $ "Nothing happens." <+> t-        IK.Hurt{} -> skip  -- avoid spam; SfxStrike just sent-        IK.Burn{} ->+        IK.Hurt{} -> return ()  -- avoid spam; SfxStrike just sent+        IK.Burn{} -> do           if fid == side then             actorVerbMU aid b "feel burned"           else             actorVerbMU aid b "look burned"-        IK.Explode{} -> skip  -- lots of visual feedback-        IK.RefillHP p | p == 1 -> skip  -- no spam from regeneration+          let ps = (bpos b, bpos b)+          animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red+          displayActorStart b animFrs+        IK.Explode{} -> return ()  -- lots of visual feedback+        IK.RefillHP p | p == 1 -> return ()  -- no spam from regeneration         IK.RefillHP p | p > 0 -> do           if fid == side then             actorVerbMU aid b "feel healthier"@@ -599,7 +661,7 @@           let ps = (bpos b, bpos b)           animFrs <- animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue           displayActorStart b animFrs-        IK.RefillHP p | p == -1 -> skip  -- no spam from poison+        IK.RefillHP p | p == -1 -> return ()  -- no spam from poison         IK.RefillHP _ -> do           if fid == side then             actorVerbMU aid b "feel wounded"@@ -624,7 +686,7 @@           let ps = (bpos b, bpos b)           animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red           displayActorStart b animFrs-        IK.RefillCalm p | p == 1 -> skip  -- no spam from regen items+        IK.RefillCalm p | p == 1 -> return ()  -- no spam from regen items         IK.RefillCalm p | p > 0 -> do           if fid == side then             actorVerbMU aid b "feel calmer"@@ -661,7 +723,7 @@           -- For subsequent messages use the proper name, never "you".           let subject = partActor b           if fid /= fidSource then do  -- before domination-            if bcalm b == 0 then do -- sometimes only a coincidence, but nm+            if bcalm b == 0 then  -- sometimes only a coincidence, but nm               aidVerbMU aid $ MU.Text "yield, under extreme pressure"             else if fid == side then               aidVerbMU aid $ MU.Text "black out, dominated by foes"@@ -677,49 +739,55 @@             let verb = "be now under"             msgAdd $ makeSentence               [MU.SubjectVerbSg subject verb, MU.Text fidSourceName, "control"]-        IK.Impress{} ->+          stopPlayBack+        IK.Impress ->           actorVerbMU aid b-          $ if boldfid b /= bfid b+          $ if bfidImpressed b /= bfid b             then-              "get refocused by the fragrant moisture"+              "get calmed and refocused"+-- TODO: only show for liquids; for others say "='flash', etc.+--              "get refocused by the fragrant moisture"             else-              "inhale the sweet smell that weakens resolve and erodes loyalty"-        IK.CallFriend{} -> skip-        IK.Summon{} -> skip+              "experience anxiety that weakens resolve and erodes loyalty"+-- TODO:        "inhale the sweet smell that weakens resolve and erodes loyalty"+        IK.CallFriend{} -> return ()+        IK.Summon{} -> return ()         IK.Ascend k | k > 0 -> actorVerbMU aid b "find a way upstairs"         IK.Ascend k | k < 0 -> actorVerbMU aid b "find a way downstairs"         IK.Ascend{} -> assert `failure` sfx-        IK.Escape{} -> skip+        IK.Escape{} -> return ()         IK.Paralyze{} -> actorVerbMU aid b "be paralyzed"         IK.InsertMove{} -> actorVerbMU aid b "act with extreme speed"         IK.Teleport t | t > 9 -> actorVerbMU aid b "teleport"         IK.Teleport{} -> actorVerbMU aid b "blink"-        IK.CreateItem{} -> skip-        IK.DropItem COrgan _ True -> skip+        IK.CreateItem{} -> return ()+        IK.DropItem COrgan _ True -> return ()         IK.DropItem _ _ False -> actorVerbMU aid b "be stripped"  -- TODO         IK.DropItem _ _ True -> actorVerbMU aid b "be violently stripped"-        IK.PolyItem cstore -> do+        IK.PolyItem -> do           localTime <- getsState $ getLocalTime $ blid b-          allAssocs <- fullAssocsClient aid [cstore]+          allAssocs <- fullAssocsClient aid [CGround]           case allAssocs of             [] -> return ()  -- invisible items?             (_, ItemFull{..}) : _ -> do+              subject <- partActorLeader aid b               let itemSecret = itemNoDisco (itemBase, itemK)-                  (secretName, secretAEText) = partItem (CActor aid cstore) (blid b) localTime itemSecret-                  subject = partActor b+                  -- TODO: plural form of secretName? only when K > 1?+                  -- At this point we don't easily know how many consumed.+                  (_, secretName, secretAEText) = partItem CGround (blid b) localTime itemSecret                   verb = "repurpose"-                  store = MU.Text $ ppCStore cstore+                  store = MU.Text $ ppCStoreIn CGround               msgAdd $ makeSentence                 [ MU.SubjectVerbSg subject verb                 , "the", secretName, secretAEText, store ]-        IK.Identify cstore -> do  -- here cstore is the real location-          allAssocs <- fullAssocsClient aid [cstore]+        IK.Identify -> do+          allAssocs <- fullAssocsClient aid [CGround]           case allAssocs of             [] -> return ()  -- invisible items?             (_, ItemFull{..}) : _ -> do-              let subject = partActor b-                  verb = "inspect"-                  store = MU.Text $ ppCStore cstore+              subject <- partActorLeader aid b+              let verb = "inspect"+                  store = MU.Text $ ppCStoreIn CGround               msgAdd $ makeSentence                 [ MU.SubjectVerbSg subject verb                 , "an item", store ]@@ -727,10 +795,10 @@         IK.PushActor{} -> actorVerbMU aid b "be pushed"         IK.PullActor{} -> actorVerbMU aid b "be pulled"         IK.DropBestWeapon -> actorVerbMU aid b "be disarmed"-        IK.ActivateInv{} -> skip+        IK.ActivateInv{} -> return ()         IK.ApplyPerfume ->           msgAdd "The fragrance quells all scents in the vicinity."-        IK.OneOf{} -> skip+        IK.OneOf{} -> return ()         IK.OnSmash{} -> assert `failure` sfx         IK.Recharging{} -> assert `failure` sfx         IK.Temporary t -> actorVerbMU aid b $ MU.Text t@@ -739,41 +807,58 @@   SfxActorStart aid -> do     arena <- getArenaUI     b <- getsState $ getActorBody aid-    activeItems <- activeItemsClient aid+--    activeItems <- activeItemsClient aid     when (blid b == arena) $ do-      -- If time clip has passed since any actor advanced level time-      -- or if the actor is so fast that he was capable of already moving-      -- this clip (for simplicity, we don't check if he actually did)+      -- If time clip has passed since any actor advanced @timeCutOff@+--TODO      -- or if the actor is so fast that he was capable of already moving+--          -- this clip (for simplicity, we don't check if he actually did)       -- or if the actor is newborn or is about to die,       -- we end the frame early, before his current move.       -- In the result, he moves at most once per frame, and thanks to this,       -- his multiple moves are not collapsed into one frame.       -- If the actor changes his speed this very clip, the test can faii,       -- but it's rare and results in a minor UI issue, so we don't care.+      localTime <- getsState $ getLocalTime (blid b)       timeCutOff <- getsClient $ EM.findWithDefault timeZero arena . sdisplayed-      when (btime b >= timeShift timeCutOff (Delta timeClip)-            || btime b >= timeShiftFromSpeed b activeItems timeCutOff+      when (localTime >= timeShift timeCutOff (Delta timeClip)+--TODO            || btime b >= timeShiftFromSpeed b activeItems timeCutOff             || actorNewBorn b             || actorDying b) $ do-        let ageDisp displayed = EM.insert arena (btime b) displayed-        modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli}-        -- If considerable time passed, show delay.-        let delta = btime b `timeDeltaToFrom` timeCutOff-        when (delta > Delta timeClip) displayDelay         -- If key will be requested, don't show the frame, because during         -- the request extra message may be shown, so the other frame is better.         mleader <- getsClient _sleader         fact <- getsState $ (EM.! bfid b) . sfactionD         let underAI = isAIFact fact-        unless (Just aid == mleader && not underAI) $+        unless (Just aid == mleader && not underAI) $ do           -- Something new is gonna happen on this level (otherwise we'd send           -- @UpdAgeLevel@ later on, with a larger time increment),           -- so show crrent game state, before it changes.-          displayPush+          -- If considerable time passed, show delay. TODO: do this more+          -- accurately --- check if, eg., projectiles generated enough+          -- frames to cover the delay and if not, add here, too.+          -- Right now, if even one projectile flies, the whole 4-clip delay+          -- is skipped.+          let delta = localTime `timeDeltaToFrom` timeCutOff+          when (delta > Delta timeClip && not (bproj b))+            displayDelay+          let ageDisp = EM.insert arena localTime+          modifyClient $ \cli -> cli {sdisplayed = ageDisp $ sdisplayed cli}+          displayPush "" +setLastSlot :: MonadClientUI m => ActorId -> ItemId -> CStore -> m ()+setLastSlot aid iid cstore = do+  b <- getsState $ getActorBody aid+  mleader <- getsClient _sleader+  when (Just aid == mleader) $ do+    (itemSlots, _) <- getsClient sslots+    case lookup iid $ map swap $ EM.assocs itemSlots of+      Just l -> modifyClient $ \cli -> cli { slastSlot = l+                                           , slastStore = cstore }+      Nothing -> assert `failure` (iid, cstore, aid, b)+ strike :: MonadClientUI m-       => ActorId -> ActorId -> ItemId -> HitAtomic -> m ()-strike source target iid hitStatus = assert (source /= target) $ do+       => ActorId -> ActorId -> ItemId -> CStore -> HitAtomic -> m ()+strike source target iid cstore hitStatus = assert (source /= target) $ do   itemToF <- itemToFullClient   sb <- getsState $ getActorBody source   tb <- getsState $ getActorBody target@@ -781,24 +866,28 @@   tpart <- partActorLeader target tb   spronoun <- partPronounLeader source sb   localTime <- getsState $ getLocalTime (blid sb)-  -- We don't show the charging status in the weapon strike message. Succinct.-  let itemFull = itemToF iid (1, [])+  bag <- getsState $ getActorBag source cstore+  let kit = EM.findWithDefault (1, []) iid bag+      itemFull = itemToF iid kit       verb = case itemDisco itemFull of         Nothing -> "hit"  -- not identified         Just ItemDisco{itemKind} -> IK.iverbHit itemKind       isOrgan = iid `EM.member` borgan sb       partItemChoice =         if isOrgan-        then partItemWownW spronoun (CActor source COrgan) (blid sb) localTime-        -- The @CEqp@ store may be fake, but it results in an item description-        -- for an active item, which is the right one for a weapon.-        else partItemAW (CActor source CEqp) (blid sb) localTime+        then partItemWownW spronoun COrgan (blid sb) localTime+        else partItemAW cstore (blid sb) localTime       msg HitClear = makeSentence $         [MU.SubjectVerbSg spart verb, tpart]         ++ if bproj sb            then []            else ["with", partItemChoice itemFull]       msg (HitBlock n) =+        -- This sounds funny when the victim falls down immediately,+        -- but there is no easy way to prevent that. And it's consistent.+        -- If/when death blow instead sets HP to 1 and only the next below 1,+        -- we can check here for HP==1; also perhaps actors with HP 1 should+        -- not be able to block.         let sActs =               if bproj sb               then [ MU.SubjectVerbSg spart "connect" ]

@@ -8,9 +8,9 @@ import Control.Exception.Assert.Sugar import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES-import qualified Data.IntMap.Strict as IM import Data.List import Data.Maybe+import Data.Ord import Data.Text (Text) import qualified Data.Text as T @@ -19,6 +19,7 @@ import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.Animation+import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor as Actor import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color@@ -35,6 +36,7 @@ import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray+import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time@@ -54,12 +56,12 @@ -- to the frontends to display separately or overlay over map, -- depending on the frontend. draw :: MonadClient m-     => Bool -> ColorMode -> LevelId+     => ColorMode -> LevelId      -> Maybe Point -> Maybe Point      -> Maybe (PointArray.Array BfsDistance, Maybe [Point])      -> (Text, Maybe Text) -> (Text, Maybe Text) -> Overlay      -> m SingleFrame-draw sfBlank dm drawnLevelId cursorPos tgtPos bfsmpathRaw+draw dm drawnLevelId cursorPos tgtPos bfsmpathRaw      (cursorDesc, mcursorHP) (targetDesc, mtargetHP) sfTop = do   cops <- getsState scops   mleader <- getsClient _sleader@@ -95,12 +97,9 @@         let tile = lvl `at` pos0             tk = tokind tile             floorBag = EM.findWithDefault EM.empty pos0 $ lfloor lvl-            (letterSlots, numberSlots) = sslots cli-            bagLetterSlots = EM.filter (`EM.member` floorBag) letterSlots-            bagNumberSlots = IM.filter (`EM.member` floorBag) numberSlots-            floorIids = reverse (EM.elems bagLetterSlots)-                        ++ IM.elems bagNumberSlots-                        ++ EM.keys floorBag+            (itemSlots, _) = sslots cli+            bagItemSlots = EM.filter (`EM.member` floorBag) itemSlots+            floorIids = EM.elems bagItemSlots  -- first slot will be shown             sml = EM.findWithDefault timeZero pos0 lsmell             smlt = sml `timeDeltaToFrom` ltime             viewActor aid Actor{bsymbol, bcolor, bhp, bproj}@@ -133,7 +132,7 @@                     && (elem pos0 bl || elem pos0 shiftedBTrajectory) ->                   ('*', atttrOnPathOrLine)  -- line takes precedence over path                 _ | isJust stgtMode-                    && (maybe False (elem pos0) mpath) ->+                    && maybe False (elem pos0) mpath ->                   (';', Color.defAttr {Color.fg = fgOnPathOrLine})                 Just (aid, m) -> viewActor aid m                 _ | smarkSmell && sml > ltime ->@@ -180,7 +179,7 @@              in fits <> ellipsis       cursorText =         let n = widthTgt - T.length pathCsr - 8-        in (if isJust stgtMode then "cursor>" else "Cursor:")+        in (if isJust stgtMode then "x-hair>" else "X-hair:")            <+> trimTgtDesc n cursorDesc       cursorGap = T.replicate (widthTgt - T.length pathCsr                                         - T.length cursorText) " "@@ -218,6 +217,7 @@       sfLevel =  -- fully evaluated         let f l y = let !line = fLine y in line : l         in foldl' f [] [lysize-1,lysize-2..0]+      sfBlank = False   return $! SingleFrame{..}  inverseVideo :: Color.Attr@@ -264,17 +264,17 @@           -- 'wait' command.           slashes = ["/", "|", "\\", "|"]           slashPick = slashes !! (max 0 (waitT - 1) `mod` length slashes)-          checkDelta ResDelta{..} =-            if resCurrentTurn < 0 || resPreviousTurn < 0-            then addColor Color.BrRed  -- alarming news have priority-            else if resCurrentTurn > 0 || resPreviousTurn > 0-                 then addColor Color.BrGreen-                 else addAttr  -- only if nothing at all noteworthy+          checkDelta ResDelta{..}+            | resCurrentTurn < 0 || resPreviousTurn < 0+              = addColor Color.BrRed  -- alarming news have priority+            | resCurrentTurn > 0 || resPreviousTurn > 0+              = addColor Color.BrGreen+            | otherwise = addAttr  -- only if nothing at all noteworthy           calmAddAttr = checkDelta calmDelta           darkPick | darkL   = "."                    | otherwise = ":"           calmHeader = calmAddAttr $ calmHeaderText <> darkPick-          calmText = bcalmS <>  (if darkL then slashPick else "/") <> acalmS+          calmText = bcalmS <> (if darkL then slashPick else "/") <> acalmS           bracePick | bracedL   = "}"                     | otherwise = ":"           hpAddAttr = checkDelta hpDelta@@ -292,12 +292,24 @@                    (T.unpack t)   stats <- case mleader of     Just leader -> do+      actorSk <- actorSkillsClient leader+      b <- getsState $ getActorBody leader+      localTime <- getsState $ getLocalTime (blid b)       allAssocs <- fullAssocsClient leader [CEqp, COrgan]       let activeItems = map snd allAssocs-          damage = case strongestSlotNoFilter IK.EqpSlotWeapon allAssocs of-            (_, (_, itemFull)) : _->+          calm10 = calmEnough10 b $ map snd allAssocs+          forced = assert (not $ bproj b) False+          permitted = permittedPrecious calm10 forced+          preferredPrecious = either (const False) id . permitted+          strongest = strongestMelee False localTime allAssocs+          strongestPreferred = filter (preferredPrecious . snd . snd) strongest+          damage = case strongestPreferred of+            _ | EM.findWithDefault 0 Ability.AbMelee actorSk <= 0 -> "0"+            [] -> "0"+            (_average, (_, itemFull)) : _ ->               let getD :: IK.Effect -> Maybe Dice.Dice -> Maybe Dice.Dice-                  getD (IK.Hurt dice) _ = Just dice+                  getD (IK.Hurt dice) acc = Just $ dice + fromMaybe 0 acc+                  getD (IK.Burn dice) acc = Just $ dice + fromMaybe 0 acc                   getD _ acc = acc                   mdice = case itemDisco itemFull of                     Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->@@ -316,7 +328,6 @@                                 <> tshow bonus                                 <> if unknownBonus then "%?" else "%"              in tdice <> tbonus-            [] -> "0"       return $! damage     Nothing -> return ""   return $! if T.null stats || T.length stats >= width then []@@ -328,28 +339,24 @@   mleader <- getsClient _sleader   selected <- getsClient sselected   side <- getsClient sside-  s <- getState-  let viewOurs (aid, Actor{bsymbol, bcolor, bhp})-        | otherwise =-          let cattr = Color.defAttr {Color.fg = bcolor}-              sattr-               | Just aid == mleader = inverseVideo-               | ES.member aid selected =-                   -- TODO: in the future use a red rectangle instead-                   -- of background and mark them on the map, too;-                   -- also, perhaps blink all selected on the map,-                   -- when selection changes-                   if bcolor /= Color.Blue-                   then cattr {Color.bg = Color.Blue}-                   else cattr {Color.bg = Color.Magenta}-               | otherwise = cattr-          in ( (bhp > 0, bsymbol /= '@', bsymbol, bcolor, aid)-             , Color.AttrChar sattr $ if bhp > 0 then bsymbol else '%' )-      ours = filter (not . bproj . snd)-             $ actorAssocs (== side) drawnLevelId s+  allOurs <- getsState $ filter ((== side) . bfid) . EM.elems . sactorD+  ours <- getsState $ filter (not . bproj . snd)+                      . actorAssocs (== side) drawnLevelId+  let viewOurs (aid, Actor{bsymbol, bcolor, bhp}) =+        let cattr = Color.defAttr {Color.fg = bcolor}+            sattr+              | Just aid == mleader = inverseVideo+              | ES.member aid selected =+                  -- TODO: in the future use a red rectangle instead+                  -- of background and mark them on the map, too;+                  -- also, perhaps blink all selected on the map,+                  -- when selection changes+                  if bcolor /= Color.Blue+                  then cattr {Color.bg = Color.Blue}+                  else cattr {Color.bg = Color.Magenta}+              | otherwise = cattr+        in Color.AttrChar sattr $ if bhp > 0 then bsymbol else '%'       maxViewed = width - 2-      -- Don't show anything if the only actor on the level is the leader.-      -- He's clearly highlighted on the level map, anyway.       star = let sattr = case ES.size selected of                    0 -> Color.defAttr {Color.fg = Color.BrBlack}                    n | n == length ours ->@@ -357,12 +364,14 @@                    _ -> Color.defAttr                  char = if length ours > maxViewed then '$' else '*'              in Color.AttrChar sattr char-      viewed = take maxViewed $ sort $ map viewOurs ours+      viewed = map viewOurs $ take maxViewed+               $ sortBy (comparing keySelected) ours       addAttr t = map (Color.AttrChar Color.defAttr) (T.unpack t)-      allOurs = filter ((== side) . bfid) $ EM.elems $ sactorD s-      party = if length allOurs <= 1+      -- Don't show anything if the only actor in the dungeon is the leader.+      -- He's clearly highlighted on the level map, anyway.+      party = if length allOurs == 1 && length ours == 1 || length ours == 0               then []-              else [star] ++ map snd viewed ++ addAttr " "+              else [star] ++ viewed ++ addAttr " "   return $! party  drawPlayerName :: MonadClient m => Int -> m [Color.AttrChar]

@@ -1,7 +1,7 @@ -- | Display game data on the screen and receive user input -- using one of the available raw frontends and derived operations. module Game.LambdaHack.Client.UI.Frontend-  ( -- * Connection types.+  ( -- * Connection types     FrontReq(..), ChanFrontend(..)     -- * Re-exported part of the raw frontend   , frontendName@@ -16,21 +16,24 @@ import qualified Data.Text.IO as T import System.IO +import Data.Maybe import qualified Game.LambdaHack.Client.Key as K import Game.LambdaHack.Client.UI.Animation import Game.LambdaHack.Client.UI.Frontend.Chosen import Game.LambdaHack.Common.ClientOptions+import Game.LambdaHack.Common.Point +-- | The instructions sent by clients to the raw frontend over a channel. data FrontReq =     FrontNormalFrame {frontFrame :: !SingleFrame}       -- ^ show a frame-  | FrontRunningFrame {frontFrame :: !SingleFrame}-      -- ^ show a frame in running mode (don't insert delay between frames)   | FrontDelay       -- ^ perform a single explicit delay   | FrontKey {frontKM :: ![K.KM], frontFr :: !SingleFrame}       -- ^ flush frames, possibly show fadeout/fadein and ask for a keypress-  | FrontSlides {frontClear :: ![K.KM], frontSlides :: ![SingleFrame]}+  | FrontSlides { frontClear   :: ![K.KM]+                , frontSlides  :: ![SingleFrame]+                , frontFromTop :: !(Maybe Bool) }       -- ^ show a whole slideshow without interleaving with other clients   | FrontAutoYes !Bool       -- ^ set the frontend option for auto-answering prompts@@ -44,8 +47,12 @@   , requestF  :: !(STM.TQueue FrontReq)   } -startupF :: DebugModeCli-         -> (Maybe (MVar ()) -> (ChanFrontend -> IO ()) -> IO ())+-- | Initialize the frontend and apply the given continuation to the results+-- of the initialization.+startupF :: DebugModeCli  -- ^ debug settings+         -> (Maybe (MVar ())+             -> (ChanFrontend -> IO ())+             -> IO ())  -- ^ continuation          -> IO () startupF dbg cont =   (if sfrontendNull dbg then nullStartup@@ -63,25 +70,19 @@ promptGetKey fs [] frame = fpromptGetKey fs frame promptGetKey fs keys frame = do   km <- fpromptGetKey fs frame-  if km `elem` keys+  if km{K.pointer=dummyPoint} `elem` keys     then return km     else promptGetKey fs keys frame -getConfirmGeneric :: Bool -> RawFrontend -> [K.KM] -> SingleFrame-                  -> IO (Maybe Bool)+getConfirmGeneric :: Bool -> RawFrontend -> [K.KM] -> SingleFrame -> IO K.KM getConfirmGeneric autoYes fs clearKeys frame = do   let DebugModeCli{sdisableAutoYes} = fdebugCli fs   if autoYes && not sdisableAutoYes then do-    fdisplay fs True (Just frame)-    return $ Just True+    fdisplay fs (Just frame)+    return K.spaceKM   else do     let extraKeys = [K.spaceKM, K.escKM, K.pgupKM, K.pgdnKM]-    km <- promptGetKey fs (clearKeys ++ extraKeys) frame-    return $! if km == K.escKM-              then Nothing-              else if km == K.pgupKM-                   then Just False-                   else Just True+    promptGetKey fs (clearKeys ++ extraKeys) frame  -- Read UI requests from the client and send them to the frontend, loopFrontend :: RawFrontend -> ChanFrontend -> IO ()@@ -95,13 +96,10 @@     efr <- STM.atomically $ STM.readTQueue requestF     case efr of       FrontNormalFrame{..} -> do-        fdisplay fs False (Just frontFrame)-        loop autoYes-      FrontRunningFrame{..} -> do-        fdisplay fs True (Just frontFrame)+        fdisplay fs (Just frontFrame)         loop autoYes       FrontDelay -> do-        fdisplay fs False Nothing+        fdisplay fs Nothing         loop autoYes       FrontKey{..} -> do         km <- promptGetKey fs frontKM frontFr@@ -116,18 +114,25 @@         let displayFrs frs srf =               case frs of                 [] -> assert `failure` "null slides" `twith` frs-                [x] -> do-                  fdisplay fs False (Just x)+                [x] | isNothing frontFromTop -> do+                  fdisplay fs (Just x)                   writeKM K.spaceKM                 x : xs -> do-                  go <- getConfirmGeneric autoYes fs frontClear x-                  case go of-                    Nothing -> writeKM K.escKM-                    Just True -> displayFrs xs (x : srf)-                    Just False -> case srf of+                  K.KM{..} <- getConfirmGeneric autoYes fs frontClear x+                  case key of+                    K.Esc -> writeKM K.escKM+                    K.PgUp -> case srf of                       [] -> displayFrs frs srf                       y : ys -> displayFrs (y : frs) ys-        displayFrs frontSlides []+                    K.Space -> case xs of+                      [] -> writeKM K.escKM  -- hack+                      _ -> displayFrs xs (x : srf)+                    _ -> case xs of  -- K.PgDn and any other permitted key+                      [] -> displayFrs frs srf+                      _ -> displayFrs xs (x : srf)+        case (frontFromTop, reverse frontSlides) of+          (Just False, r : rs) -> displayFrs [r] rs+          _ -> displayFrs frontSlides []         loop autoYes       FrontAutoYes b ->         loop b

@@ -26,7 +26,7 @@ frontendName = Chosen.frontendName  data RawFrontend = RawFrontend-  { fdisplay      :: Bool -> Maybe SingleFrame -> IO ()+  { fdisplay      :: Maybe SingleFrame -> IO ()   , fpromptGetKey :: SingleFrame -> IO K.KM   , fsyncFrames   :: IO ()   , fescMVar      :: !(Maybe (MVar ()))@@ -36,7 +36,7 @@ chosenStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO () chosenStartup fdebugCli cont =   Chosen.startup fdebugCli $ \fs ->-    cont $ RawFrontend+    cont RawFrontend       { fdisplay = Chosen.fdisplay fs       , fpromptGetKey = Chosen.fpromptGetKey fs       , fsyncFrames = Chosen.fsyncFrames fs@@ -47,7 +47,7 @@ stdStartup :: DebugModeCli -> (RawFrontend -> IO ()) -> IO () stdStartup fdebugCli cont =   Std.startup fdebugCli $ \fs ->-    cont $ RawFrontend+    cont RawFrontend       { fdisplay = Std.fdisplay fs       , fpromptGetKey = Std.fpromptGetKey fs       , fsyncFrames = Std.fsyncFrames fs@@ -59,8 +59,8 @@ nullStartup fdebugCli cont =   -- Std used to fork (async) the server thread, to avoid bound thread overhead.   Std.startup fdebugCli $ \_ ->-    cont $ RawFrontend-      { fdisplay = \_ _ -> return ()+    cont RawFrontend+      { fdisplay = \_ -> return ()       , fpromptGetKey = \_ -> return K.escKM       , fsyncFrames = return ()       , fescMVar = Nothing

@@ -61,11 +61,10 @@  -- | Output to the screen via the frontend. fdisplay :: FrontendSession    -- ^ frontend session data-         -> Bool          -> Maybe SingleFrame  -- ^ the screen frame to draw          -> IO ()-fdisplay _ _ Nothing = return ()-fdisplay FrontendSession{..}  _ (Just rawSF) = do+fdisplay _ Nothing = return ()+fdisplay FrontendSession{..}  (Just rawSF) = do   let SingleFrame{sfLevel} = overlayOverlay rawSF   -- let defaultStyle = C.defaultCursesStyle   -- Terminals with white background require this:@@ -93,11 +92,11 @@ -- | Display a prompt, wait for any key. fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM fpromptGetKey sess frame = do-  fdisplay sess True $ Just frame+  fdisplay sess $ Just frame   nextEvent  keyTranslate :: C.Key -> K.KM-keyTranslate e = (\(key, modifier) -> K.KM {..}) $+keyTranslate e = (\(key, modifier) -> K.toKM modifier key) $   case e of     C.KeyChar '\ESC' -> (K.Esc,     K.NoModifier)     C.KeyExit        -> (K.Esc,     K.NoModifier)

@@ -15,7 +15,6 @@ import Control.Concurrent.Async import qualified Control.Concurrent.STM as STM import qualified Control.Exception as Ex hiding (handle)-import Control.Exception.Assert.Sugar import Control.Monad import Control.Monad.Reader import qualified Data.ByteString.Char8 as BS@@ -33,6 +32,7 @@ import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.LQueue+import Game.LambdaHack.Common.Point  data FrameState =     FPushed  -- frames stored in a queue, to be drawn in equal time intervals@@ -79,7 +79,7 @@   case fs of     FPushed{..} ->       putMVar sframeState FPushed{fpushed = f fpushed, ..}-    _ ->+    FNone ->       putMVar sframeState fs  -- | The name of the frontend.@@ -101,7 +101,7 @@   unsafeInitGUIForThreadedRTS   -- Text attributes.   ttt <- textTagTableNew-  stags <- fmap M.fromList $+  stags <- M.fromList <$>              mapM (\ ak -> do                       tt <- textTagNew Nothing                       textTagTableAdd ttt tt@@ -116,7 +116,7 @@   textViewSetEditable sview False   textViewSetCursorVisible sview False   -- Set up the channel for keyboard input.-  schanKey <- STM.atomically $ STM.newTQueue+  schanKey <- STM.atomically STM.newTQueue   -- Set up the frame state.   let frameState = FNone   -- Create the session record.@@ -131,6 +131,9 @@   -- Fork the thread that periodically draws a frame from a queue, if any.   aPoll <- async $ pollFramesAct sess `Ex.finally` postGUISync mainQuit   link aPoll+  let flushChanKey = do+        res <- STM.atomically $ STM.tryReadTQueue schanKey+        when (isJust res) flushChanKey   -- Fill the keyboard channel.   sview `on` keyPressEvent $ do     n <- eventKeyName@@ -140,28 +143,37 @@ #else     let !key = K.keyTranslate n #endif-        !modifier = modifierTranslate mods-        readAll = do-          res <- STM.atomically $ STM.tryReadTQueue schanKey-          when (isJust res) $ readAll+        !modifier = let md = modifierTranslate mods+                    in if md == K.Shift then K.NoModifier else md+        !pointer = dummyPoint     liftIO $ do       unless (deadKey n) $ do         -- If ESC, also mark it specially and reset the key channel.         when (key == K.Esc) $ do           void $ tryPutMVar escMVar ()-          readAll+          flushChanKey         -- Store the key in the channel.-        STM.atomically $ STM.writeTQueue schanKey K.KM{key, modifier}+        STM.atomically $ STM.writeTQueue schanKey K.KM{..}       return True   -- Set the font specified in config, if any.   f <- fontDescriptionFromString $ fromMaybe "" sfont   widgetModifyFont sview (Just f)+  liftIO $ do+    textViewSetLeftMargin sview 3+    textViewSetRightMargin sview 3   -- Prepare font chooser dialog.   currentfont <- newIORef f+  Just display <- displayGetDefault+  -- TODO: change cursor depending on targeting mode, etc.; hard+  cursor <- cursorNewForDisplay display Tcross  -- Target Crosshair Arrow   sview `on` buttonPressEvent $ do+    liftIO flushChanKey     but <- eventButton-    liftIO $ case but of-      RightButton -> do+    (wx, wy) <- eventCoordinates+    mods <- eventModifier+    let !modifier = modifierTranslate mods  -- Shift included+    liftIO $ do+      when (but == RightButton && modifier == K.Control) $ do         fsd <- fontSelectionDialogNew ("Choose font" :: String)         cf  <- readIORef currentfont         fds <- fontDescriptionToString cf@@ -177,8 +189,28 @@               widgetModifyFont sview (Just fd)             Nothing  -> return ()         widgetDestroy fsd-        return True-      _ -> return False+      -- We shouldn't pass on the click if the user has selected something.+      hasSelection <- textBufferHasSelection tb+      unless hasSelection $ do+        mdrawWin <- displayGetWindowAtPointer display+        let setCursor (drawWin, _, _) =+              drawWindowSetCursor drawWin (Just cursor)+        maybe (return ()) setCursor mdrawWin+        (bx, by) <-+          textViewWindowToBufferCoords sview TextWindowText+                                       (round wx, round wy)+        (iter, _) <- textViewGetIterAtPosition sview bx by+        cx <- textIterGetLineOffset iter+        cy <- textIterGetLine iter+        let !key = case but of+              LeftButton -> K.LeftButtonPress+              MiddleButton -> K.MiddleButtonPress+              RightButton -> K.RightButtonPress+              _ -> K.LeftButtonPress+            !pointer = Point cx (cy - 1)+        -- Store the mouse even coords in the keypress channel.+        STM.atomically $ STM.writeTQueue schanKey K.KM{..}+    return $! but == RightButton  -- not to disable selection   -- Modify default colours.   let black = Color minBound minBound minBound  -- Color.defBG == Color.Black       white = Color 0xC500 0xBC00 0xB800        -- Color.defFG == Color.White@@ -244,7 +276,7 @@ microInSec = 1000000  defaultMaxFps :: Int-defaultMaxFps = 15+defaultMaxFps = 30  -- | Poll the frame queue often and draw frames at fixed intervals. pollFramesWait :: FrontendSession -> ClockTime -> IO ()@@ -300,7 +332,7 @@           -- (otherwise it would change the state), so poll often.           threadDelay $ microInSec `div` maxPolls maxFps           pollFramesAct sess-    _ -> do+    FNone -> do       putMVar sframeState fs       -- Not in the Push state, so poll lazily to catch the next state change.       -- The slow polling also gives the game logic a head start@@ -311,8 +343,8 @@  -- | Add a game screen frame to the frame drawing channel, or show -- it ASAP if @immediate@ display is requested and the channel is empty.-pushFrame :: FrontendSession -> Bool -> Bool -> Maybe SingleFrame -> IO ()-pushFrame sess noDelay immediate rawFrame = do+pushFrame :: FrontendSession -> Bool -> Maybe SingleFrame -> IO ()+pushFrame sess immediate rawFrame = do   let FrontendSession{sframeState, slastFull} = sess   -- Full evaluation is done outside the mvar locks.   let !frame = case rawFrame of@@ -329,24 +361,27 @@   case fs of     FPushed{..} ->       putMVar sframeState-      $ if isNothing nextFrame && anyFollowed+      $ if isNothing nextFrame && anyFollowed && isJust rawFrame         then fs  -- old news         else FPushed{fpushed = writeLQueue fpushed nextFrame, ..}     FNone | immediate -> do       -- If the frame not repeated, draw it.-      maybe skip (postGUIAsync . output sess) nextFrame+      maybe (return ()) (postGUIAsync . output sess) nextFrame       -- Frame sent, we may now safely release the queue lock.       putMVar sframeState FNone     FNone ->-      -- Never start playing with an empty frame.-      let fpushed = if isJust nextFrame-                    then writeLQueue newLQueue nextFrame-                    else newLQueue-          fshown = dummyFrame-      in putMVar sframeState FPushed{..}+      putMVar sframeState+      $ if isNothing nextFrame && anyFollowed && isJust rawFrame+        then fs  -- old news+        else FPushed{ fpushed = writeLQueue newLQueue nextFrame+                    , fshown = dummyFrame }   case nextFrame of-    Nothing -> putMVar slastFull (lastFrame, True)-    Just f  -> putMVar slastFull (f, noDelay)+    Nothing -> putMVar slastFull (lastFrame, not (case fs of+                                                    FNone -> True+                                                    FPushed{} -> False+                                                  && immediate+                                                  && not anyFollowed))+    Just f  -> putMVar slastFull (f, False)  evalFrame :: FrontendSession -> SingleFrame -> GtkFrame evalFrame FrontendSession{stags} rawSF =@@ -379,7 +414,7 @@                           then Nothing  -- no sense repeating                           else Just frame           -- Draw the last frame ASAP.-          maybe skip (postGUIAsync . output sess) nextFrame+          maybe (return ()) (postGUIAsync . output sess) nextFrame         Nothing -> return ()     FNone -> return ()   -- Wipe out the frame queue. Release the lock.@@ -387,10 +422,9 @@  -- | Add a frame to be drawn. fdisplay :: FrontendSession    -- ^ frontend session data-         -> Bool          -> Maybe SingleFrame  -- ^ the screen frame to draw          -> IO ()-fdisplay sess noDelay = pushFrame sess noDelay False+fdisplay sess = pushFrame sess False  -- Display all queued frames, synchronously. displayAllFramesSync :: FrontendSession -> FrameState -> IO ()@@ -417,7 +451,7 @@         Nothing ->           -- The queue is empty.           return ()-    _ ->+    FNone ->       -- Not in Push state to start with.       return () @@ -433,7 +467,7 @@ fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM fpromptGetKey sess@FrontendSession{..}               frame = do-  pushFrame sess True True $ Just frame+  pushFrame sess True $ Just frame   km <- STM.atomically $ STM.readTQueue schanKey   case km of     K.KM{key=K.Space} ->@@ -470,24 +504,27 @@  -- | Translates modifiers to our own encoding. modifierTranslate :: [Modifier] -> K.Modifier-modifierTranslate mods =-  if Control `elem` mods then K.Control else K.NoModifier+modifierTranslate mods+  | Control `elem` mods = K.Control+  | any (`elem` mods) [Meta, Super, Alt, Alt2, Alt3, Alt4, Alt5] = K.Alt+  | Shift `elem` mods = K.Shift+  | otherwise = K.NoModifier  doAttr :: DebugModeCli -> TextTag -> Color.Attr -> IO () doAttr sdebugCli tt attr@Color.Attr{fg, bg}   | attr == Color.defAttr = return ()-  | fg == Color.defFG = set tt $ extraAttr sdebugCli-                                 ++ [textTagBackground := Color.colorToRGB bg]-  | bg == Color.defBG = set tt $ extraAttr sdebugCli-                                 ++ [textTagForeground := Color.colorToRGB fg]-  | otherwise         = set tt $ extraAttr sdebugCli-                                 ++ [ textTagForeground := Color.colorToRGB fg-                                    , textTagBackground := Color.colorToRGB bg ]+  | fg == Color.defFG =+    set tt $ extraAttr sdebugCli+             ++ [textTagBackground := Color.colorToRGB bg]+  | bg == Color.defBG =+    set tt $ extraAttr sdebugCli+             ++ [textTagForeground := Color.colorToRGB fg]+  | otherwise =+    set tt $ extraAttr sdebugCli+             ++ [ textTagForeground := Color.colorToRGB fg+                , textTagBackground := Color.colorToRGB bg ]  extraAttr :: DebugModeCli -> [AttrOp TextTag] extraAttr DebugModeCli{scolorIsBold} =-  if scolorIsBold == Just True-  then [ textTagWeight := fromEnum WeightBold+  [textTagWeight := fromEnum WeightBold | scolorIsBold == Just True] --     , textTagStretch := StretchUltraExpanded-       ]-  else []

@@ -39,11 +39,10 @@  -- | Output to the screen via the frontend. fdisplay :: FrontendSession    -- ^ frontend session data-         -> Bool          -> Maybe SingleFrame  -- ^ the screen frame to draw          -> IO ()-fdisplay _ _ Nothing = return ()-fdisplay _ _ (Just rawSF) =+fdisplay _ Nothing = return ()+fdisplay _ (Just rawSF) =   let SingleFrame{sfLevel} = overlayOverlay rawSF       bs = map (BS.pack . map Color.acChar . decodeLine) sfLevel ++ [BS.empty]   in mapM_ BS.putStrLn bs@@ -63,11 +62,11 @@ -- | Display a prompt, wait for any key. fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM fpromptGetKey sess frame = do-  fdisplay sess True $ Just frame+  fdisplay sess $ Just frame   nextEvent  keyTranslate :: Char -> K.KM-keyTranslate e = (\(key, modifier) -> K.KM {..}) $+keyTranslate e = (\(key, modifier) -> K.toKM modifier key) $   case e of     '\ESC' -> (K.Esc,     K.NoModifier)     '\n'   -> (K.Return,  K.NoModifier)

@@ -10,19 +10,20 @@  import Control.Concurrent import Control.Concurrent.Async+import qualified Control.Concurrent.STM as STM import qualified Control.Exception as Ex hiding (handle)+import Control.Monad import Data.Default+import Data.Maybe import Graphics.Vty import qualified Graphics.Vty as Vty-import qualified Control.Concurrent.STM as STM-import Control.Monad-import Data.Maybe  import qualified Game.LambdaHack.Client.Key as K import Game.LambdaHack.Client.UI.Animation import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color import Game.LambdaHack.Common.Msg+import Game.LambdaHack.Common.Point  -- | Session data maintained by the frontend. data FrontendSession = FrontendSession@@ -41,7 +42,7 @@ startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO () startup sdebugCli k = do   svty <- mkVty def-  schanKey <- STM.atomically $ STM.newTQueue+  schanKey <- STM.atomically STM.newTQueue   escMVar <- newEmptyMVar   let sess = FrontendSession{sescMVar = Just escMVar, ..}   void $ async $ storeKeys sess@@ -55,28 +56,28 @@     EvKey n mods -> do       let !key = keyTranslate n           !modifier = modifierTranslate mods+          !pointer = dummyPoint           readAll = do             res <- STM.atomically $ STM.tryReadTQueue schanKey-            when (isJust res) $ readAll+            when (isJust res) readAll       -- If ESC, also mark it specially and reset the key channel.       case sescMVar of-        Just escMVar -> do+        Just escMVar ->           when (key == K.Esc) $ do             void $ tryPutMVar escMVar ()             readAll         Nothing -> return ()       -- Store the key in the channel.-      STM.atomically $ STM.writeTQueue schanKey K.KM{key, modifier}+      STM.atomically $ STM.writeTQueue schanKey K.KM{..}     _ -> return ()   storeKeys sess  -- | Output to the screen via the frontend. fdisplay :: FrontendSession    -- ^ frontend session data-         -> Bool          -> Maybe SingleFrame  -- ^ the screen frame to draw          -> IO ()-fdisplay _ _ Nothing = return ()-fdisplay FrontendSession{svty} _ (Just rawSF) =+fdisplay _ Nothing = return ()+fdisplay FrontendSession{svty} (Just rawSF) =   let SingleFrame{sfLevel} = overlayOverlay rawSF       img = (foldr (<->) emptyImage              . map (foldr (<|>) emptyImage@@ -111,7 +112,7 @@ -- | Display a prompt, wait for any key. fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM fpromptGetKey sess frame = do-  fdisplay sess True $ Just frame+  fdisplay sess $ Just frame   nextKeyEvent sess  -- TODO: Ctrl-Home and Ctrl-End are the same as Home and End on some terminals@@ -142,8 +143,11 @@  -- | Translates modifiers to our own encoding. modifierTranslate :: [Modifier] -> K.Modifier-modifierTranslate mods =-  if MCtrl `elem` mods then K.Control else K.NoModifier+modifierTranslate mods+  | MCtrl `elem` mods = K.Control+  | MAlt `elem` mods = K.Alt+  | MShift `elem` mods = K.Shift+  | otherwise = K.NoModifier  -- TODO: with vty 5.0 check if bold is still needed. -- A hack to get bright colors via the bold attribute. Depending on terminal

@@ -19,14 +19,14 @@ -- invoked in targeting mode on a remote level (level different than -- the level of the leader). cmdHumanSem :: MonadClientUI m => HumanCmd -> m (SlideOrCmd RequestUI)-cmdHumanSem cmd = do+cmdHumanSem cmd =   if noRemoteHumanCmd cmd then do     -- If in targeting mode, check if the current level is the same     -- as player level and refuse performing the action otherwise.     arena <- getArenaUI     lidV <- viewedLevel-    if (arena /= lidV) then-      failWith $ "command disabled on a remote level, press ESC to switch back"+    if arena /= lidV then+      failWith "command disabled on a remote level, press ESC to switch back"     else cmdAction cmd   else cmdAction cmd @@ -34,16 +34,20 @@ cmdAction :: MonadClientUI m => HumanCmd -> m (SlideOrCmd RequestUI) cmdAction cmd = case cmd of   -- Global.-  Move v -> fmap anyToUI <$> moveRunHuman False v-  Run v -> fmap anyToUI <$> moveRunHuman True v+  Move v -> fmap anyToUI <$> moveRunHuman True True False False v+  Run v -> fmap anyToUI <$> moveRunHuman True True True True v   Wait -> Right <$> fmap ReqUITimed waitHuman   MoveItem cLegalRaw toCStore mverb _ auto ->     fmap ReqUITimed <$> moveItemHuman cLegalRaw toCStore mverb auto+  DescribeItem cstore -> fmap ReqUITimed <$> describeItemHuman cstore   Project ts -> fmap ReqUITimed <$> projectHuman ts   Apply ts -> fmap ReqUITimed <$> applyHuman ts   AlterDir ts -> fmap ReqUITimed <$> alterDirHuman ts   TriggerTile ts -> fmap ReqUITimed <$> triggerTileHuman ts-  StepToTarget -> fmap anyToUI <$> stepToTargetHuman+  RunOnceAhead -> fmap anyToUI <$> runOnceAheadHuman+  MoveOnceToCursor -> fmap anyToUI <$> moveOnceToCursorHuman+  RunOnceToCursor  -> fmap anyToUI <$> runOnceToCursorHuman+  ContinueToCursor -> fmap anyToUI <$> continueToCursorHuman    GameRestart t -> gameRestartHuman t   GameExit -> gameExitHuman@@ -56,11 +60,11 @@   PickLeader k -> Left <$> pickLeaderHuman k   MemberCycle -> Left <$> memberCycleHuman   MemberBack -> Left <$> memberBackHuman-  DescribeItem cstore -> Left <$> describeItemHuman cstore-  AllOwned -> Left <$> allOwnedHuman-  SelectActor -> Left <$> selectActorHuman+  SelectActor -> addNoSlides selectActorHuman   SelectNone -> addNoSlides selectNoneHuman   Clear -> addNoSlides clearHuman+  StopIfTgtMode -> addNoSlides stopIfTgtModeHuman+  SelectWithPointer -> addNoSlides selectWithPointer   Repeat n -> addNoSlides $ repeatHuman n   Record -> Left <$> recordHuman   History -> Left <$> historyHuman@@ -74,14 +78,18 @@   MoveCursor v k -> Left <$> moveCursorHuman v k   TgtFloor -> Left <$> tgtFloorHuman   TgtEnemy -> Left <$> tgtEnemyHuman-  TgtUnknown -> Left <$> tgtUnknownHuman-  TgtItem -> Left <$> tgtItemHuman-  TgtStair up -> Left <$> tgtStairHuman up   TgtAscend k -> Left <$> tgtAscendHuman k   EpsIncr b -> Left <$> epsIncrHuman b   TgtClear -> Left <$> tgtClearHuman+  CursorUnknown -> Left <$> cursorUnknownHuman+  CursorItem -> Left <$> cursorItemHuman+  CursorStair up -> Left <$> cursorStairHuman up   Cancel -> Left <$> cancelHuman mainMenuHuman   Accept -> Left <$> acceptHuman helpHuman+  CursorPointerFloor -> addNoSlides cursorPointerFloorHuman+  CursorPointerEnemy -> addNoSlides cursorPointerEnemyHuman+  TgtPointerFloor -> Left <$> tgtPointerFloorHuman+  TgtPointerEnemy -> Left <$> tgtPointerEnemyHuman  addNoSlides :: Monad m => m () -> m (SlideOrCmd RequestUI) addNoSlides cmdCli = cmdCli >> return (Left mempty)

@@ -7,9 +7,10 @@ -- TODO: document module Game.LambdaHack.Client.UI.HandleHumanGlobalClient   ( -- * Commands that usually take time-    moveRunHuman, waitHuman, moveItemHuman+    moveRunHuman, waitHuman, moveItemHuman, describeItemHuman   , projectHuman, applyHuman, alterDirHuman, triggerTileHuman-  , stepToTargetHuman+  , runOnceAheadHuman, moveOnceToCursorHuman+  , runOnceToCursorHuman, continueToCursorHuman     -- * Commands that never take time   , gameRestartHuman, gameExitHuman, gameSaveHuman, tacticHuman, automateHuman   ) where@@ -22,7 +23,6 @@ import Data.List import Data.Maybe import Data.Monoid-import qualified Data.Text as T import qualified NLP.Miniutter.English as MU  import Game.LambdaHack.Client.BfsClient@@ -64,16 +64,42 @@ -- * Move and Run  moveRunHuman :: MonadClientUI m-             => Bool -> Vector -> m (SlideOrCmd RequestAnyAbility)-moveRunHuman run dir = do+             => Bool -> Bool -> Bool -> Bool -> Vector+             -> m (SlideOrCmd RequestAnyAbility)+moveRunHuman initialStep finalGoal run runAhead dir = do   tgtMode <- getsClient stgtMode   if isJust tgtMode then-    fmap Left $ moveCursorHuman dir (if run then 10 else 1)+    Left <$> moveCursorHuman dir (if run then 10 else 1)   else do     arena <- getArenaUI     leader <- getLeaderUI     sb <- getsState $ getActorBody leader     fact <- getsState $ (EM.! bfid sb) . sfactionD+    -- Start running in the given direction. The first turn of running+    -- succeeds much more often than subsequent turns, because we ignore+    -- most of the disturbances, since the player is mostly aware of them+    -- and still explicitly requests a run, knowing how it behaves.+    sel <- getsClient sselected+    let runMembers = if runAhead || noRunWithMulti fact+                     then [leader]  -- TODO: warn?+                     else ES.toList (ES.delete leader sel) ++ [leader]+        runParams = RunParams { runLeader = leader+                              , runMembers+                              , runInitial = True+                              , runStopMsg = Nothing+                              , runWaiting = 0 }+        macroRun25 = ["CTRL-comma", "CTRL-V"]+    when (initialStep && run) $ do+      modifyClient $ \cli ->+        cli {srunning = Just runParams}+      when runAhead $+        modifyClient $ \cli ->+          cli {slastPlay = map K.mkKM macroRun25 ++ slastPlay cli}+    -- When running, the invisible actor is hit (not displaced!),+    -- so that running in the presence of roving invisible+    -- actors is equivalent to moving (with visible actors+    -- this is not a problem, since runnning stops early enough).+    -- TODO: stop running at invisible actor     let tpos = bpos sb `shift` dir     -- We start by checking actors at the the target position,     -- which gives a partial information (actors can be invisible),@@ -82,39 +108,22 @@     tgts <- getsState $ posToActors tpos arena     case tgts of       [] -> do  -- move or search or alter-        -- Start running in the given direction. The first turn of running-        -- succeeds much more often than subsequent turns, because we ignore-        -- most of the disturbances, since the player is mostly aware of them-        -- and still explicitly requests a run, knowing how it behaves.-        runStopOrCmd <- moveRunAid leader dir+        runStopOrCmd <- moveSearchAlterAid leader dir         case runStopOrCmd of           Left stopMsg -> failWith stopMsg-          Right runCmd@(RequestAnyAbility ReqMove{}) -> do-            sel <- getsClient sselected-            let runMembers = if noRunWithMulti fact-                             then [leader]  -- TODO: warn?-                             else ES.toList (ES.delete leader sel) ++ [leader]-                runParams = RunParams { runLeader = leader-                                      , runMembers-                                      , runDist = 0-                                      , runStopMsg = Nothing-                                      , runInitDir = Just dir }-            when run $ modifyClient $ \cli -> cli {srunning = Just runParams}+          Right runCmd ->+            -- Don't check @initialStep@ and @finalGoal@+            -- and don't stop going to target: door opening is mundane enough.             return $ Right runCmd-          -- Any other command does ends the run immediately.-          Right runCmd -> return $ Right runCmd-        -- When running, the invisible actor is hit (not displaced!),-        -- so that running in the presence of roving invisible-        -- actors is equivalent to moving (with visible actors-        -- this is not a problem, since runnning stops early enough).-        -- TODO: stop running at invisible actor-      [((target, _), _)] | run ->+      [((target, _), _)] | run && initialStep ->+        -- No @stopPlayBack@: initial displace is benign enough.         -- Displacing requires accessibility, but it's checked later on.         fmap RequestAnyAbility <$> displaceAid target-      _ : _ : _ | run -> do-        assert (all (bproj . snd . fst) tgts) skip+      _ : _ : _ | run && initialStep -> do+        let !_A = assert (all (bproj . snd . fst) tgts) ()         failSer DisplaceProjectiles-      ((target, tb), _) : _ -> do+      ((target, tb), _) : _ | initialStep && finalGoal -> do+        stopPlayBack  -- don't ever auto-repeat melee         -- No problem if there are many projectiles at the spot. We just         -- attack the first one.         -- We always see actors from our own faction.@@ -124,16 +133,17 @@           else do             -- Select adjacent actor by bumping into him. Takes no time.             success <- pickLeader True target-            assert (success `blame` "bump self"-                            `twith` (leader, target, tb)) skip+            let !_A = assert (success `blame` "bump self"+                                      `twith` (leader, target, tb)) ()             return $ Left mempty         else           -- Attacking does not require full access, adjacency is enough.           fmap RequestAnyAbility <$> meleeAid target+      _ : _ -> failWith "actor in the way"  -- | Actor atttacks an enemy actor or his own projectile. meleeAid :: MonadClientUI m-         => ActorId -> m (SlideOrCmd (RequestTimed AbMelee))+         => ActorId -> m (SlideOrCmd (RequestTimed 'AbMelee)) meleeAid target = do   leader <- getLeaderUI   sb <- getsState $ getActorBody leader@@ -141,18 +151,18 @@   sfact <- getsState $ (EM.! bfid sb) . sfactionD   mel <- pickWeaponClient leader target   case mel of-    [] -> failWith "nothing to melee with"-    wp : _ -> do+    Nothing -> failWith "nothing to melee with"+    Just wp -> do       let returnCmd = return $ Right wp           res | bproj tb || isAtWar sfact (bfid tb) = returnCmd               | isAllied sfact (bfid tb) = do                 go1 <- displayYesNo ColorBW                          "You are bound by an alliance. Really attack?"-                if not go1 then failWith "Attack canceled." else returnCmd+                if not go1 then failWith "attack canceled" else returnCmd               | otherwise = do                 go2 <- displayYesNo ColorBW                          "This attack will start a war. Are you sure?"-                if not go2 then failWith "Attack canceled." else returnCmd+                if not go2 then failWith "attack canceled" else returnCmd       res   -- Seeing the actor prevents altering a tile under it, but that   -- does not limit the player, he just doesn't waste a turn@@ -160,7 +170,7 @@  -- | Actor swaps position with another. displaceAid :: MonadClientUI m-            => ActorId -> m (SlideOrCmd (RequestTimed AbDisplace))+            => ActorId -> m (SlideOrCmd (RequestTimed 'AbDisplace)) displaceAid target = do   cops <- getsState scops   leader <- getLeaderUI@@ -169,9 +179,8 @@   tfact <- getsState $ (EM.! bfid tb) . sfactionD   activeItems <- activeItemsClient target   disp <- getsState $ dispEnemy leader target activeItems-  actorSk <- getsState $ maxActorSkills target activeItems-  let immobile = EM.findWithDefault 0 AbDisplace actorSk <= 0-                 && EM.findWithDefault 0 AbMove actorSk <= 0+  let actorMaxSk = sumSkills activeItems+      immobile = EM.findWithDefault 0 AbMove actorMaxSk <= 0       spos = bpos sb       tpos = bpos tb       adj = checkAdjacent sb tb@@ -192,15 +201,60 @@       tgts <- getsState $ posToActors tpos lid       case tgts of         [] -> assert `failure` (leader, sb, target, tb)-        [_] -> do-          return $ Right $ ReqDisplace target+        [_] -> return $ Right $ ReqDisplace target         _ -> failSer DisplaceProjectiles     else failSer DisplaceAccess +-- | Actor moves or searches or alters. No visible actor at the position.+moveSearchAlterAid :: MonadClient m+                   => ActorId -> Vector -> m (Either Msg RequestAnyAbility)+moveSearchAlterAid source dir = do+  cops@Kind.COps{cotile} <- getsState scops+  sb <- getsState $ getActorBody source+  let lid = blid sb+  lvl <- getLevel lid+  let spos = bpos sb           -- source position+      tpos = spos `shift` dir  -- target position+      t = lvl `at` tpos+      runStopOrCmd+        -- Movement requires full access.+        | accessible cops lvl spos tpos =+            -- A potential invisible actor is hit. War started without asking.+            Right $ RequestAnyAbility $ ReqMove dir+        -- No access, so search and/or alter the tile. Non-walkability is+        -- not implied by the lack of access.+        | not (Tile.isWalkable cotile t)+                && (not (knownLsecret lvl)+                    || (isSecretPos lvl tpos  -- possible secrets here+                        && (Tile.isSuspect cotile t  -- not yet searched+                            || Tile.hideAs cotile t /= t))  -- search again+                    || Tile.isOpenable cotile t+                    || Tile.isClosable cotile t+                    || Tile.isChangeable cotile t)+          = if EM.member tpos $ lfloor lvl then+              Left $ showReqFailure AlterBlockItem+            else+              Right $ RequestAnyAbility $ ReqAlter tpos Nothing+            -- We don't use MoveSer, because we don't hit invisible actors.+            -- The potential invisible actor, e.g., in a wall or in+            -- an inaccessible doorway, is made known, taking a turn.+            -- If server performed an attack for free+            -- on the invisible actor anyway, the player (or AI)+            -- would be tempted to repeatedly hit random walls+            -- in hopes of killing a monster lurking within.+            -- If the action had a cost, misclicks would incur the cost, too.+            -- Right now the player may repeatedly alter tiles trying to learn+            -- about invisible pass-wall actors, but when an actor detected,+            -- it costs a turn and does not harm the invisible actors,+            -- so it's not so tempting.+        -- Ignore a known boring, not accessible tile.+        | otherwise = Left "never mind"+  return $! runStopOrCmd+ -- * Wait  -- | Leader waits a turn (and blocks, etc.).-waitHuman :: MonadClientUI m => m (RequestTimed AbWait)+waitHuman :: MonadClientUI m => m (RequestTimed 'AbWait) waitHuman = do   modifyClient $ \cli -> cli {swaitTimes = abs (swaitTimes cli) + 1}   return ReqWait@@ -208,76 +262,122 @@ -- * MoveItem  moveItemHuman :: MonadClientUI m-              => [CStore] -> CStore -> (Maybe MU.Part) -> Bool-              -> m (SlideOrCmd (RequestTimed AbMoveItem))+              => [CStore] -> CStore -> Maybe MU.Part -> Bool+              -> m (SlideOrCmd (RequestTimed 'AbMoveItem)) moveItemHuman cLegalRaw destCStore mverb auto = do-  assert (destCStore `notElem` cLegalRaw) skip+  let !_A = assert (destCStore `notElem` cLegalRaw) ()   let verb = fromMaybe (MU.Text $ verbCStore destCStore) mverb   leader <- getLeaderUI   b <- getsState $ getActorBody leader   activeItems <- activeItemsClient leader-  let cLegal = if calmEnough b activeItems-               then cLegalRaw-               else if destCStore == CSha-                    then []-                    else delete CSha cLegalRaw+  -- This calmE is outdated when one of the items increases max Calm+  -- (e.g., in pickup, which handles many items at once), but this is OK,+  -- the server accepts item movement based on calm at the start, not end+  -- or in the middle.+  -- The calmE is inaccurate also if an item not IDed, but that's intended+  -- and the server will ignore and warn (and content may avoid that,+  -- e.g., making all rings identified)+  let calmE = calmEnough b activeItems+      cLegal | calmE = cLegalRaw+             | destCStore == CSha = []+             | otherwise = delete CSha cLegalRaw+      ret4 :: MonadClientUI m+           => CStore -> [(ItemId, ItemFull)]+           -> Int -> [(ItemId, Int, CStore, CStore)]+           -> m (Either Slideshow [(ItemId, Int, CStore, CStore)])+      ret4 _ [] _ acc = return $ Right $ reverse acc+      ret4 fromCStore ((iid, itemFull) : rest) oldN acc = do+        let k = itemK itemFull+            retRec toCStore =+              let n = oldN + if toCStore == CEqp then k else 0+              in ret4 fromCStore rest n ((iid, k, fromCStore, toCStore) : acc)+        if cLegalRaw == [CGround]  -- normal pickup+        then case destCStore of+          CEqp | calmE && goesIntoSha itemFull ->+            retRec CSha+          CEqp | goesIntoInv itemFull ->+            retRec CInv+          CEqp | eqpOverfull b (oldN + k) -> do+            msgAdd $ "Warning:" <+> showReqFailure EqpOverfull <> "."+            retRec CInv+          _ ->+            retRec destCStore+        else case destCStore of+          CEqp | eqpOverfull b (oldN + k) -> failSer EqpOverfull+          _ -> retRec destCStore   ggi <- if auto-         then getAnyItem verb cLegalRaw cLegal False False-         else getAnyItem verb cLegalRaw cLegal True True+         then getAnyItems verb cLegalRaw cLegal False False+         else getAnyItems verb cLegalRaw cLegal True True   case ggi of-    Right ((iid, itemFull), CActor _ fromCStore) -> do-      let k = itemK itemFull-          retReq toCStore =-            return $ Right $ ReqMoveItem iid k fromCStore toCStore-      if fromCStore == CGround-      then case destCStore of-        CEqp | goesIntoInv (itemBase itemFull) ->-          retReq CInv-        CEqp | eqpOverfull b k -> do-          msgAdd $ "Warning:" <+> showReqFailure EqpOverfull <> "."-          retReq CInv-        _ ->-          retReq destCStore-      else case destCStore of-        CEqp | eqpOverfull b k -> failSer EqpOverfull-        _ -> retReq destCStore+    Right (l, MStore fromCStore) -> do+      leader2 <- getLeaderUI+      b2 <- getsState $ getActorBody leader2+      activeItems2 <- activeItemsClient leader2+      let calmE2 = calmEnough b2 activeItems2+      -- This is not ideal, because the failure message comes late,+      -- but it's simple and good enough.+      if not calmE2 && destCStore == CSha then failSer ItemNotCalm+      else do+        l4 <- ret4 fromCStore l 0 []+        return $! case l4 of+          Left sli -> Left sli+          Right [] -> assert `failure` ggi+          Right lr -> Right $ ReqMoveItems lr     Left slides -> return $ Left slides     _ -> assert `failure` ggi +-- * DescribeItem++-- | Display items from a given container store and describe the chosen one.+describeItemHuman :: MonadClientUI m+                  => ItemDialogMode -> m (SlideOrCmd (RequestTimed 'AbMoveItem))+describeItemHuman = describeItemC+ -- * Project -projectHuman :: MonadClientUI m-             => [Trigger] -> m (SlideOrCmd (RequestTimed AbProject))+projectHuman :: forall m. MonadClientUI m+             => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbProject)) projectHuman ts = do   leader <- getLeaderUI-  tgtPos <- leaderTgtToPos+  lidV <- viewedLevel+  oldTgtMode <- getsClient stgtMode+  -- Show the targeting line, temporarily.+  modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode lidV}+  -- Set cursor to the personal target, permanently.   tgt <- getsClient $ getTarget leader-  case tgtPos of-    Nothing -> failWith "last target invalid"-    Just pos -> do-      -- Set cursor to the personal target, temporarily.-      oldCursor <- getsClient scursor-      modifyClient $ \cli -> cli {scursor = fromMaybe (scursor cli) tgt}-      -- Show the targeting line, temporarily.-      oldTgtMode <- getsClient stgtMode-      lidV <- viewedLevel-      modifyClient $ \cli -> cli {stgtMode = Just $ TgtMode lidV}-      canAim <- leaderTgtAims-      oldEps <- getsClient seps-      outcome <- case canAim of-        Right newEps -> do-          -- Modify @seps@,, temporarily.-          modifyClient $ \cli -> cli {seps = newEps}-          projectPos ts pos+  modifyClient $ \cli -> cli {scursor = fromMaybe (scursor cli) tgt}+  -- Let the user pick the item to fling.+  let posFromCursor :: m (Either Msg Point)+      posFromCursor = do+        canAim <- aidTgtAims leader lidV Nothing+        case canAim of+          Right newEps -> do+            -- Modify @seps@, permanently.+            modifyClient $ \cli -> cli {seps = newEps}+            mpos <- aidTgtToPos leader lidV Nothing+            case mpos of+              Nothing -> assert `failure` (tgt, leader, lidV)+              Just pos -> do+                munit <- projectCheck pos+                case munit of+                  Nothing -> return $ Right pos+                  Just reqFail -> return $ Left $ showReqFailure reqFail+          Left cause -> return $ Left cause+  mitem <- projectItem ts posFromCursor+  outcome <- case mitem of+    Right (iid, fromCStore) -> do+      mpos <- posFromCursor+      case mpos of+        Right pos -> do+          eps <- getsClient seps+          return $ Right $ ReqProject pos eps iid fromCStore         Left cause -> failWith cause-      modifyClient $ \cli -> cli { stgtMode = oldTgtMode-                                 , scursor = oldCursor-                                 , seps = oldEps }-      return outcome+    Left sli -> return $ Left sli+  modifyClient $ \cli -> cli {stgtMode = oldTgtMode}+  return outcome -projectPos :: MonadClientUI m-           => [Trigger] -> Point -> m (SlideOrCmd (RequestTimed AbProject))-projectPos ts tpos = do+projectCheck :: MonadClientUI m => Point -> m (Maybe ReqFailure)+projectCheck tpos = do   Kind.COps{cotile} <- getsState scops   leader <- getLeaderUI   eps <- getsClient seps@@ -286,48 +386,70 @@       spos = bpos sb   Level{lxsize, lysize} <- getLevel lid   case bla lxsize lysize eps spos tpos of-    Nothing -> failSer ProjectAimOnself+    Nothing -> return $ Just ProjectAimOnself     Just [] -> assert `failure` "project from the edge of level"-                      `twith` (spos, tpos, sb, ts)+                      `twith` (spos, tpos, sb)     Just (pos : _) -> do       lvl <- getLevel lid       let t = lvl `at` pos       if not $ Tile.isWalkable cotile t-        then failSer ProjectBlockTerrain+        then return $ Just ProjectBlockTerrain         else do           mab <- getsState $ posToActor pos lid           if maybe True (bproj . snd . fst) mab-          then projectEps ts tpos eps-          else failSer ProjectBlockActor+          then return Nothing+          else return $ Just ProjectBlockActor -projectEps :: MonadClientUI m-           => [Trigger] -> Point -> Int-           -> m (SlideOrCmd (RequestTimed AbProject))-projectEps ts tpos eps = do+projectItem :: forall m. MonadClientUI m+            => [Trigger] -> m (Either Msg Point)+            -> m (SlideOrCmd (ItemId, CStore))+projectItem ts posFromCursor = do   leader <- getLeaderUI   b <- getsState $ getActorBody leader+  activeItems <- activeItemsClient leader   actorSk <- actorSkillsClient leader   let skill = EM.findWithDefault 0 AbProject actorSk-  activeItems <- activeItemsClient leader-  let cLegal = [CGround, CInv, CEqp]+      cLegal = [CGround, CInv, CEqp, CSha]       (verb1, object1) = case ts of         [] -> ("aim", "item")         tr : _ -> (verb tr, object tr)       triggerSyms = triggerSymbols ts-      p itemFull@ItemFull{itemBase} =-        let legal = permittedProject triggerSyms False skill itemFull b activeItems-        in case legal of-          Left{} -> legal-          Right False -> legal-          Right True -> Right $ totalRange itemBase >= chessDist (bpos b) tpos+      psuitReq :: m (Either Msg (ItemFull -> Either ReqFailure Bool))+      psuitReq = do+        mpos <- posFromCursor+        case mpos of+          Left err -> return $ Left err+          Right pos -> return $ Right $ \itemFull@ItemFull{itemBase} -> do+            let legal = permittedProject triggerSyms False skill+                                         itemFull b activeItems+            case legal of+              Left{} -> legal+              Right False -> legal+              Right True ->+                Right $ totalRange itemBase >= chessDist (bpos b) pos+      psuit :: m Suitability+      psuit = do+        mpsuitReq <- psuitReq+        case mpsuitReq of+          -- If target invalid, no item is considered a (suitable) missile.+          Left err -> return $ SuitsNothing err+          Right psuitReqFun -> return $ SuitsSomething $ \itemFull ->+            case psuitReqFun itemFull of+              Left _ -> False+              Right suit -> suit       prompt = makePhrase ["What", object1, "to", verb1]-      promptGeneric = "What item to fling"-  ggi <- getGroupItem (either (const False) id . p) prompt promptGeneric cLegal cLegal+      promptGeneric = "What to fling"+  ggi <- getGroupItem psuit prompt promptGeneric True+                      cLegal cLegal   case ggi of-    Right ((iid, itemFull), CActor _ fromCStore) ->-      case p itemFull of-        Left reqFail -> failSer reqFail-        Right _ -> return $ Right $ ReqProject tpos eps iid fromCStore+    Right ((iid, itemFull), MStore fromCStore) -> do+      mpsuitReq <- psuitReq+      case mpsuitReq of+        Left err -> failWith err+        Right psuitReqFun ->+          case psuitReqFun itemFull of+            Left reqFail -> failSer reqFail+            Right _ -> return $ Right (iid, fromCStore)     Left slides -> return $ Left slides     _ -> assert `failure` ggi @@ -339,24 +461,27 @@ -- * Apply  applyHuman :: MonadClientUI m-           => [Trigger] -> m (SlideOrCmd (RequestTimed AbApply))+           => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbApply)) applyHuman ts = do   leader <- getLeaderUI   b <- getsState $ getActorBody leader   actorSk <- actorSkillsClient leader   let skill = EM.findWithDefault 0 AbProject actorSk   activeItems <- activeItemsClient leader-  let cLegal = [CGround, CInv, CEqp]+  localTime <- getsState $ getLocalTime (blid b)+  let cLegal = [CGround, CInv, CEqp, CSha]       (verb1, object1) = case ts of-        [] -> ("activate", "item")+        [] -> ("apply", "item")         tr : _ -> (verb tr, object tr)       triggerSyms = triggerSymbols ts-      p itemFull = permittedApply triggerSyms skill itemFull b activeItems+      p itemFull =+        permittedApply triggerSyms localTime skill itemFull b activeItems       prompt = makePhrase ["What", object1, "to", verb1]-      promptGeneric = "What item to activate"-  ggi <- getGroupItem (either (const False) id . p) prompt promptGeneric cLegal cLegal+      promptGeneric = "What to apply"+  ggi <- getGroupItem (return $ SuitsSomething $ either (const False) id . p)+                      prompt promptGeneric False cLegal cLegal   case ggi of-    Right ((iid, itemFull), CActor _ fromCStore) ->+    Right ((iid, itemFull), MStore fromCStore) ->       case p itemFull of         Left reqFail -> failSer reqFail         Right _ -> return $ Right $ ReqApply iid fromCStore@@ -365,37 +490,43 @@  -- * AlterDir +-- TODO: accept mouse, too -- | Ask for a direction and alter a tile, if possible. alterDirHuman :: MonadClientUI m-              => [Trigger] -> m (SlideOrCmd (RequestTimed AbAlter))+              => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbAlter)) alterDirHuman ts = do   Config{configVi, configLaptop} <- askConfig   let verb1 = case ts of         [] -> "alter"         tr : _ -> verb tr-      keys = zipWith K.KM (repeat K.NoModifier)-                          (K.dirAllKey configVi configLaptop)+      keys = map (K.toKM K.NoModifier) (K.dirAllKey configVi configLaptop)       prompt = makePhrase ["What to", verb1 <> "? [movement key"]   me <- displayChoiceUI prompt emptyOverlay keys   case me of     Left slides -> failSlides slides-    Right e -> K.handleDir configVi configLaptop e (flip alterTile ts)+    Right e -> K.handleDir configVi configLaptop e (`alterTile` ts)                                                    (failWith "never mind")  -- | Player tries to alter a tile using a feature. alterTile :: MonadClientUI m-          => Vector -> [Trigger] -> m (SlideOrCmd (RequestTimed AbAlter))+          => Vector -> [Trigger] -> m (SlideOrCmd (RequestTimed 'AbAlter)) alterTile dir ts = do   cops@Kind.COps{cotile} <- getsState scops   leader <- getLeaderUI   b <- getsState $ getActorBody leader   lvl <- getLevel $ blid b+  as <- getsState $ actorList (const True) (blid b)   let tpos = bpos b `shift` dir       t = lvl `at` tpos       alterFeats = alterFeatures ts   case filter (\feat -> Tile.hasFeature cotile feat t) alterFeats of     [] -> failWith $ guessAlter cops alterFeats t-    feat : _ -> return $ Right $ ReqAlter tpos $ Just feat+    feat : _ ->+      if EM.notMember tpos $ lfloor lvl then+        if unoccupied as tpos then+          return $ Right $ ReqAlter tpos $ Just feat+        else failSer AlterBlockActor+      else failSer AlterBlockItem  alterFeatures :: [Trigger] -> [TK.Feature] alterFeatures [] = []@@ -416,7 +547,7 @@  -- | Leader tries to trigger the tile he's standing on. triggerTileHuman :: MonadClientUI m-                 => [Trigger] -> m (SlideOrCmd (RequestTimed AbTrigger))+                 => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbTrigger)) triggerTileHuman ts = do   tgtMode <- getsClient stgtMode   if isJust tgtMode then do@@ -427,12 +558,12 @@         mk = getK ts     case mk of       Nothing -> failWith "never mind"-      Just k -> fmap Left $ tgtAscendHuman k+      Just k -> Left <$> tgtAscendHuman k   else triggerTile ts  -- | Player tries to trigger a tile using a feature. triggerTile :: MonadClientUI m-            => [Trigger] -> m (SlideOrCmd (RequestTimed AbTrigger))+            => [Trigger] -> m (SlideOrCmd (RequestTimed 'AbTrigger)) triggerTile ts = do   cops@Kind.COps{cotile} <- getsState scops   leader <- getLeaderUI@@ -465,18 +596,18 @@       "This is the way out, but where would you go in this alien world?"     else do       go <- displayYesNo ColorFull "This is the way out. Really leave now?"-      if not go then failWith "Game resumed."+      if not go then failWith "game resumed"       else do         (_, total) <- getsState $ calculateTotal b         if total == 0 then do           -- The player can back off at each of these steps.           go1 <- displayMore ColorBW                    "Afraid of the challenge? Leaving so soon and empty-handed?"-          if not go1 then failWith "Brave soul!"+          if not go1 then failWith "brave soul!"           else do              go2 <- displayMore ColorBW                      "Next time try to grab some loot before escape!"-             if not go2 then failWith "Here's your chance!"+             if not go2 then failWith "here's your chance!"              else return $ Right ()         else return $ Right ()   _ -> return $ Right ()@@ -494,33 +625,139 @@     else assert `failure` fs guessTrigger _ _ _ = "never mind" --- * StepToTarget+-- * RunOnceAhead -stepToTargetHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)-stepToTargetHuman = do+runOnceAheadHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)+runOnceAheadHuman = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  leader <- getLeaderUI+  srunning <- getsClient srunning+  -- When running, stop if disturbed. If not running, stop at once.+  case srunning of+    Nothing -> do+      stopPlayBack+      return $ Left mempty+    Just RunParams{runMembers}+      | noRunWithMulti fact && runMembers /= [leader] -> do+      stopPlayBack+      Config{configRunStopMsgs} <- askConfig+      if configRunStopMsgs+      then failWith "run stop: automatic leader change"+      else return $ Left mempty+    Just runParams -> do+      arena <- getArenaUI+      runOutcome <- continueRun arena runParams+      case runOutcome of+        Left stopMsg -> do+          stopPlayBack+          Config{configRunStopMsgs} <- askConfig+          if configRunStopMsgs+          then failWith $ "run stop:" <+> stopMsg+          else return $ Left mempty+        Right runCmd ->+          return $ Right runCmd++-- * MoveOnceToCursor++moveOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)+moveOnceToCursorHuman = goToCursor True False++goToCursor :: MonadClientUI m+           => Bool -> Bool -> m (SlideOrCmd RequestAnyAbility)+goToCursor initialStep run = do   tgtMode <- getsClient stgtMode   -- Movement is legal only outside targeting mode.-  -- TODO: use this command for something in targeting mode.-  if isJust tgtMode then failWith "cannot move in targeting mode"+  if isJust tgtMode then failWith "cannot move in aiming mode"   else do     leader <- getLeaderUI     b <- getsState $ getActorBody leader-    tgtPos <- leaderTgtToPos-    case tgtPos of-      Nothing -> failWith "target not set"-      Just c | c == bpos b -> failWith "target reached"+    cursorPos <- cursorToPos+    case cursorPos of+      Nothing -> failWith "no leader"+      Just c | c == bpos b ->+        if initialStep+        then return $ Right $ RequestAnyAbility ReqWait+        else do+          report <- getsClient sreport+          if nullReport report+          then return $ Left mempty+          -- Mark that the messages are accumulated, not just from last move.+          else failWith "crosshair now reached"       Just c -> do-        (_, mpath) <- getCacheBfsAndPath leader c+        running <- getsClient srunning+        case running of+          -- Don't use running params from previous run or goto-cursor.+          Just paramOld | not initialStep -> do+            arena <- getArenaUI+            runOutcome <- multiActorGoTo arena c paramOld+            case runOutcome of+              Left stopMsg -> failWith stopMsg+              Right (finalGoal, dir) ->+                moveRunHuman initialStep finalGoal run False dir+          _ -> do+            let !_A = assert (initialStep || not run) ()+            (_, mpath) <- getCacheBfsAndPath leader c+            case mpath of+              Nothing -> failWith "no route to crosshair"+              Just [] -> assert `failure` (leader, b, c)+              Just (p1 : _) -> do+                let finalGoal = p1 == c+                    dir = towards (bpos b) p1+                moveRunHuman initialStep finalGoal run False dir++multiActorGoTo :: MonadClient m+               => LevelId -> Point -> RunParams+               -> m (Either Msg (Bool, Vector))+multiActorGoTo arena c paramOld =+  case paramOld of+    RunParams{runMembers = []} ->+      return $ Left "selected actors no longer there"+    RunParams{runMembers = r : rs, runWaiting} -> do+      onLevel <- getsState $ memActor r arena+      if not onLevel then do+        let paramNew = paramOld {runMembers = rs}+        multiActorGoTo arena c paramNew+      else do+        s <- getState+        modifyClient $ updateLeader r s+        let runMembersNew = rs ++ [r]+            paramNew = paramOld { runMembers = runMembersNew+                                , runWaiting = 0}+        b <- getsState $ getActorBody r+        (_, mpath) <- getCacheBfsAndPath r c         case mpath of-          Nothing -> failWith "no route to target"-          Just [] -> assert `failure` (leader, b, bpos b, c)+          Nothing -> return $ Left "no route to crosshair"+          Just [] ->+            -- This actor already at goal; will be caught in goToCursor.+            return $ Left ""           Just (p1 : _) -> do-            as <- getsState $ posToActors p1 (blid b)-            if not $ null as then-              failWith "actor in the path to target"-            else-              moveRunHuman False $ towards (bpos b) p1+            let finalGoal = p1 == c+                dir = towards (bpos b) p1+                tpos = bpos b `shift` dir+            tgts <- getsState $ posToActors tpos arena+            case tgts of+              [] -> do+                modifyClient $ \cli -> cli {srunning = Just paramNew}+                return $ Right (finalGoal, dir)+              [((target, _), _)]+                | target `elem` rs || runWaiting <= length rs ->+                -- Let r wait until all others move. Mark it in runWaiting+                -- to avoid cycles. When all wait for each other, fail.+                multiActorGoTo arena c paramNew{runWaiting=runWaiting + 1}+              _ ->+                 return $ Left "actor in the way" +-- * RunOnceToCursor++runOnceToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)+runOnceToCursorHuman = goToCursor True True++-- * ContinueToCursor++continueToCursorHuman :: MonadClientUI m => m (SlideOrCmd RequestAnyAbility)+continueToCursorHuman = goToCursor False False{-irrelevant-}+ -- * GameRestart; does not take time  gameRestartHuman :: MonadClientUI m => GroupName ModeKind -> m (SlideOrCmd RequestUI)@@ -541,8 +778,8 @@       b2 <- displayYesNo ColorBW               "Current progress will be lost! Really restart the game?"       msg2 <- rndToAction $ oneOf-                [ "Yea, would be a pity to leave them all to die."-                , "Yea, a shame to get your own team stranded." ]+                [ "yea, would be a pity to leave them all to die"+                , "yea, a shame to get your own team stranded" ]       if not b2 then failWith msg2       else restart @@ -555,7 +792,7 @@     leader <- getLeaderUI     DebugModeCli{sdifficultyCli} <- getsClient sdebugCli     return $ Right $ ReqUIGameExit leader sdifficultyCli-  else failWith "Save and exit canceled."+  else failWith "save and exit canceled"  -- * GameSave; does not take time @@ -582,10 +819,10 @@   let toT = if fromT == maxBound then minBound else succ fromT   go <- displayMore ColorFull         $ "Switching tactic to"-          <+> T.pack (show toT)  -- tshow eats up parens+          <+> tshow toT           <> ". (This clears targets.)"   if not go-    then failWith "Tactic change canceled."+    then failWith "tactic change canceled"     else return $ Right $ ReqUITactic toT  -- * Automate; does not take time@@ -599,5 +836,5 @@   else do     go <- displayMore ColorBW "Ceding control to AI (ESC to regain)."     if not go-      then failWith "Automation canceled."+      then failWith "automation canceled"       else return $ Right ReqUIAutomate