LambdaHack 0.4.99.0 → 0.4.100.0

raw patch · 101 files changed

+5231/−3256 lines, 101 filesdep +data-defaultdep ~miniutterdep ~vtyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: data-default

Dependency ranges changed: miniutter, vty

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• Game/LambdaHack/Atomic/BroadcastAtomicWrite.hs +9/−5
• Game/LambdaHack/Atomic/CmdAtomic.hs +23/−23
• Game/LambdaHack/Atomic/HandleAtomicWrite.hs +33/−16
• Game/LambdaHack/Atomic/MonadStateWrite.hs +59/−33
• Game/LambdaHack/Atomic/PosAtomicRead.hs +23/−14
• Game/LambdaHack/Client/AI.hs +1/−0
• Game/LambdaHack/Client/AI/ConditionClient.hs +33/−20
• Game/LambdaHack/Client/AI/HandleAbilityClient.hs +140/−94
• Game/LambdaHack/Client/AI/PickActorClient.hs +3/−0
• Game/LambdaHack/Client/AI/PickTargetClient.hs +20/−9
• Game/LambdaHack/Client/AI/Preferences.hs +98/−70
• Game/LambdaHack/Client/Bfs.hs +51/−35
• Game/LambdaHack/Client/BfsClient.hs +51/−54
• Game/LambdaHack/Client/CommonClient.hs +17/−14
• Game/LambdaHack/Client/HandleAtomicClient.hs +22/−17
• Game/LambdaHack/Client/ItemSlot.hs +8/−4
• Game/LambdaHack/Client/Key.hs +52/−20
• Game/LambdaHack/Client/State.hs +15/−4
• Game/LambdaHack/Client/UI.hs +17/−4
• Game/LambdaHack/Client/UI/Config.hs +4/−0
• Game/LambdaHack/Client/UI/DisplayAtomicClient.hs +288/−169
• Game/LambdaHack/Client/UI/DrawClient.hs +13/−15
• Game/LambdaHack/Client/UI/Frontend.hs +19/−16
• Game/LambdaHack/Client/UI/Frontend/Curses.hs +1/−0
• Game/LambdaHack/Client/UI/Frontend/Gtk.hs +37/−15
• Game/LambdaHack/Client/UI/Frontend/Vty.hs +70/−33
• Game/LambdaHack/Client/UI/HandleHumanClient.hs +2/−2
• Game/LambdaHack/Client/UI/HandleHumanGlobalClient.hs +115/−107
• Game/LambdaHack/Client/UI/HandleHumanLocalClient.hs +41/−31
• Game/LambdaHack/Client/UI/HumanCmd.hs +12/−6
• Game/LambdaHack/Client/UI/InventoryClient.hs +82/−72
• Game/LambdaHack/Client/UI/MonadClientUI.hs +12/−8
• Game/LambdaHack/Client/UI/MsgClient.hs +18/−11
• Game/LambdaHack/Client/UI/RunClient.hs +8/−7
• Game/LambdaHack/Client/UI/WidgetClient.hs +11/−2
• Game/LambdaHack/Common/Actor.hs +37/−12
• Game/LambdaHack/Common/ActorState.hs +82/−52
• Game/LambdaHack/Common/ClientOptions.hs +17/−14
• Game/LambdaHack/Common/ContentDef.hs +4/−4
• Game/LambdaHack/Common/Dice.hs +25/−10
• Game/LambdaHack/Common/Effect.hs +0/−217
• Game/LambdaHack/Common/EffectDescription.hs +106/−81
• Game/LambdaHack/Common/Faction.hs +7/−6
• Game/LambdaHack/Common/Feature.hs +0/−39
• Game/LambdaHack/Common/File.hs +18/−7
• Game/LambdaHack/Common/Flavour.hs +39/−11
• Game/LambdaHack/Common/Frequency.hs +23/−23
• Game/LambdaHack/Common/HighScore.hs +1/−1
• Game/LambdaHack/Common/Item.hs +16/−13
• Game/LambdaHack/Common/ItemDescription.hs +101/−41
• Game/LambdaHack/Common/ItemStrongest.hs +81/−47
• Game/LambdaHack/Common/Kind.hs +6/−6
• Game/LambdaHack/Common/Level.hs +10/−9
• Game/LambdaHack/Common/Misc.hs +35/−6
• Game/LambdaHack/Common/Msg.hs +36/−25
• Game/LambdaHack/Common/PointArray.hs +45/−6
• Game/LambdaHack/Common/Request.hs +122/−19
• Game/LambdaHack/Common/State.hs +2/−1
• Game/LambdaHack/Common/Tile.hs +59/−45
• Game/LambdaHack/Common/Time.hs +15/−5
• Game/LambdaHack/Content/CaveKind.hs +17/−11
• Game/LambdaHack/Content/ItemKind.hs +221/−12
• Game/LambdaHack/Content/ModeKind.hs +35/−48
• Game/LambdaHack/Content/PlaceKind.hs +3/−2
• Game/LambdaHack/Content/RuleKind.hs +2/−2
• Game/LambdaHack/Content/TileKind.hs +59/−25
• Game/LambdaHack/Server/Commandline.hs +9/−5
• Game/LambdaHack/Server/CommonServer.hs +124/−79
• Game/LambdaHack/Server/DebugServer.hs +9/−9
• Game/LambdaHack/Server/DungeonGen.hs +17/−15
• Game/LambdaHack/Server/DungeonGen/Cave.hs +1/−1
• Game/LambdaHack/Server/DungeonGen/Place.hs +9/−8
• Game/LambdaHack/Server/EndServer.hs +17/−20
• Game/LambdaHack/Server/Fov.hs +45/−28
• Game/LambdaHack/Server/Fov/Digital.hs +25/−18
• Game/LambdaHack/Server/HandleEffectServer.hs +602/−381
• Game/LambdaHack/Server/HandleRequestServer.hs +90/−55
• Game/LambdaHack/Server/ItemRev.hs +20/−18
• Game/LambdaHack/Server/ItemServer.hs +72/−35
• Game/LambdaHack/Server/LoopServer.hs +43/−33
• Game/LambdaHack/Server/MonadServer.hs +25/−8
• Game/LambdaHack/Server/PeriodicServer.hs +26/−21
• Game/LambdaHack/Server/StartServer.hs +26/−18
• Game/LambdaHack/Server/State.hs +3/−2
• GameDefinition/Client/UI/Content/KeyKind.hs +21/−17
• GameDefinition/Content/ItemKind.hs +382/−209
• GameDefinition/Content/ItemKindActor.hs +57/−26
• GameDefinition/Content/ItemKindBlast.hs +455/−0
• GameDefinition/Content/ItemKindOrgan.hs +75/−56
• GameDefinition/Content/ItemKindShrapnel.hs +0/−256
• GameDefinition/Content/ItemKindTemporary.hs +75/−0
• GameDefinition/Content/ModeKind.hs +19/−8
• GameDefinition/Content/ModeKindPlayer.hs +19/−14
• GameDefinition/Content/TileKind.hs +10/−10
• GameDefinition/PLAYING.md +16/−20
• GameDefinition/config.ui.default +18/−6
• LambdaHack.cabal +39/−16
• Makefile +153/−96
• README.md +83/−36
• test/test.hs +2/−2

@@ -1,3 +1,15 @@+## [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+- make a couple of skill levels meaningful and tweak skills of some actors+- make AI prefer exploration of easier levels+- permit overfull HP and Calm+- let non-projectile actors block view+- make colorful characters bold (if it resizes your fonts, turn off via colorIsBold = False in config file or --noColorIsBold on commandline)+- start the game with a screensaver safari mode+- add i386 Linux and Windows compilation targets to Makefile+ ## [v0.4.99.0, aka 'Player escapes'](https://github.com/LambdaHack/LambdaHack/compare/v0.2.14...v0.4.99.0)  - balance the example game content a bit (campaign still unbalanced)

@@ -167,10 +167,14 @@       inActor = map fActor inPrio       -- Items.       pMaybe p = maybe Nothing (\x -> Just (p, x))-      inFloor = mapMaybe (\p -> pMaybe p $ EM.lookup p (lfloor lvl)) inFov-      fItem p (iid, k) = UpdSpotItem iid (getItemBody iid s) k (CFloor lid p)-      fBag (p, bag) = map (fItem p) $ EM.assocs bag-      inItem = concatMap fBag inFloor+      inContainer fc itemFloor =+        let inItem = mapMaybe (\p -> pMaybe p $ EM.lookup p itemFloor) inFov+            fItem p (iid, kit) =+              UpdSpotItem iid (getItemBody iid s) kit (fc lid p)+            fBag (p, bag) = map (fItem p) $ EM.assocs bag+        in concatMap fBag inItem+      inFloor = inContainer CFloor (lfloor lvl)+      inEmbed = inContainer CEmbed (lembed lvl)       -- Tiles.       inTileMap = map (\p -> (p, hideTile (scops s) lvl p)) inFov       atomicTile = if null inTileMap then [] else [UpdSpotTile lid inTileMap]@@ -178,4 +182,4 @@       inSmellFov = ES.elems $ smellVisible inPer       inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl)) inSmellFov       atomicSmell = if null inSm then [] else [UpdSpotSmell lid inSm]-  in inItem ++ inActor ++ atomicTile ++ atomicSmell+  in inFloor ++ inEmbed ++ inActor ++ atomicTile ++ atomicSmell

@@ -24,9 +24,8 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ClientOptions import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Effect as Effect+import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level@@ -37,9 +36,10 @@ import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.ItemKind (ItemKind) import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Content.TileKind as TK  data CmdAtomic =     UpdAtomic !UpdAtomic@@ -53,12 +53,12 @@   -- Create/destroy actors and items.     UpdCreateActor !ActorId !Actor ![(ItemId, Item)]   | UpdDestroyActor !ActorId !Actor ![(ItemId, Item)]-  | UpdCreateItem !ItemId !Item !Int !Container-  | UpdDestroyItem !ItemId !Item !Int !Container+  | UpdCreateItem !ItemId !Item !ItemQuant !Container+  | UpdDestroyItem !ItemId !Item !ItemQuant !Container   | UpdSpotActor !ActorId !Actor ![(ItemId, Item)]   | UpdLoseActor !ActorId !Actor ![(ItemId, Item)]-  | UpdSpotItem !ItemId !Item !Int !Container-  | UpdLoseItem !ItemId !Item !Int !Container+  | UpdSpotItem !ItemId !Item !ItemQuant !Container+  | UpdLoseItem !ItemId !Item !ItemQuant !Container   -- Move actors and items.   | UpdMoveActor !ActorId !Point !Point   | UpdWaitActor !ActorId !Bool@@ -69,9 +69,7 @@   | UpdRefillHP !ActorId !Int64   | UpdRefillCalm !ActorId !Int64   | UpdOldFidActor !ActorId !FactionId !FactionId-  | UpdTrajectory !ActorId-                       !(Maybe ([Vector], Speed))-                       !(Maybe ([Vector], Speed))+  | UpdTrajectory !ActorId !(Maybe ([Vector], Speed)) !(Maybe ([Vector], Speed))   | UpdColorActor !ActorId !Color.Color !Color.Color   -- Change faction attributes.   | UpdQuitFaction !FactionId !(Maybe Actor) !(Maybe Status) !(Maybe Status)@@ -92,6 +90,7 @@   | UpdSpotSmell !LevelId ![(Point, Time)]   | UpdLoseSmell !LevelId ![(Point, Time)]   -- 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@@ -101,7 +100,7 @@   | UpdCoverSeed !LevelId !Point !ItemId !ItemSeed   | UpdPerception !LevelId !Perception !Perception   | UpdRestart-      !FactionId !DiscoveryKind !FactionPers !State !DebugModeCli !GroupName+      !FactionId !DiscoveryKind !FactionPers !State !DebugModeCli !(GroupName ModeKind)   | UpdRestartServer !State   | UpdResume !FactionId !FactionPers   | UpdResumeServer !State@@ -117,13 +116,13 @@ data SfxAtomic =     SfxStrike !ActorId !ActorId !ItemId !HitAtomic   | SfxRecoil !ActorId !ActorId !ItemId !HitAtomic-  | SfxProject !ActorId !ItemId-  | SfxCatch !ActorId !ItemId-  | SfxActivate !ActorId !ItemId !Int-  | SfxCheck !ActorId !ItemId !Int-  | SfxTrigger !ActorId !Point !F.Feature-  | SfxShun !ActorId !Point !F.Feature-  | SfxEffect !FactionId !ActorId !(Effect.Effect Int)+  | SfxProject !ActorId !ItemId !CStore+  | SfxCatch !ActorId !ItemId !CStore+  | SfxActivate !ActorId !ItemId !CStore+  | SfxCheck !ActorId !ItemId !CStore+  | SfxTrigger !ActorId !Point !TK.Feature+  | SfxShun !ActorId !Point !TK.Feature+  | SfxEffect !FactionId !ActorId !(IK.Effect)   | SfxMsgFid !FactionId !Msg   | SfxMsgAll !Msg   | SfxActorStart !ActorId@@ -174,6 +173,7 @@   UpdAlterSmell lid p fromSm toSm -> Just $ UpdAlterSmell lid p toSm fromSm   UpdSpotSmell lid sms -> Just $ UpdLoseSmell lid sms   UpdLoseSmell lid sms -> Just $ UpdSpotSmell lid sms+  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@@ -195,10 +195,10 @@ undoSfxAtomic cmd = case cmd of   SfxStrike source target iid b -> SfxRecoil source target iid b   SfxRecoil source target iid b -> SfxStrike source target iid b-  SfxProject aid iid -> SfxCatch aid iid-  SfxCatch aid iid -> SfxProject aid iid-  SfxActivate aid iid k -> SfxCheck aid iid k-  SfxCheck aid iid k -> SfxActivate aid iid k+  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   SfxTrigger aid p feat -> SfxShun aid p feat   SfxShun aid p feat -> SfxTrigger aid p feat   SfxEffect{} -> cmd  -- not ideal?

@@ -32,9 +32,9 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.ModeKind as ModeKind-import Game.LambdaHack.Content.TileKind as TileKind+import Game.LambdaHack.Content.ItemKind (ItemKind)+import Game.LambdaHack.Content.ModeKind+import Game.LambdaHack.Content.TileKind (TileKind)  -- | The game-state semantics of atomic game commands. -- Special effects (@SfxAtomic@) don't modify state.@@ -47,12 +47,12 @@ handleUpdAtomic cmd = case cmd of   UpdCreateActor aid body ais -> updCreateActor aid body ais   UpdDestroyActor aid body ais -> updDestroyActor aid body ais-  UpdCreateItem iid item k c -> updCreateItem iid item k c-  UpdDestroyItem iid item k c -> updDestroyItem iid item k c+  UpdCreateItem iid item kit c -> updCreateItem iid item kit c+  UpdDestroyItem iid item kit c -> updDestroyItem iid item kit c   UpdSpotActor aid body ais -> updCreateActor aid body ais   UpdLoseActor aid body ais -> updDestroyActor aid body ais-  UpdSpotItem iid item k c -> updCreateItem iid item k c-  UpdLoseItem iid item k c -> updDestroyItem iid item k c+  UpdSpotItem iid item kit c -> updCreateItem iid item kit c+  UpdLoseItem iid item kit c -> updDestroyItem iid item kit c   UpdMoveActor aid fromP toP -> updMoveActor aid fromP toP   UpdWaitActor aid toWait -> updWaitActor aid toWait   UpdDisplaceActor source target -> updDisplaceActor source target@@ -80,6 +80,7 @@   UpdAlterSmell lid p fromSm toSm -> updAlterSmell lid p fromSm toSm   UpdSpotSmell lid sms -> updSpotSmell lid sms   UpdLoseSmell lid sms -> updLoseSmell lid sms+  UpdTimeItem iid c fromIt toIt -> updTimeItem iid c fromIt toIt   UpdAgeGame t lids -> updAgeGame t lids   UpdDiscover{} -> return ()      -- We can't keep dicovered data in State,   UpdCover{} -> return ()         -- because server saves all atomic commands@@ -163,8 +164,8 @@ -- | Create a few copies of an item that is already registered for the dungeon -- (in @sitemRev@ field of @StateServer@). updCreateItem :: MonadStateWrite m-              => ItemId -> Item -> Int -> Container -> m ()-updCreateItem iid item k c = assert (k > 0) $ do+              => ItemId -> Item -> ItemQuant -> Container -> m ()+updCreateItem iid item kit@(k, _) c = assert (k > 0) $ do   -- The item may or may not be already present in @sitemD@,   -- regardless if it's actually present in the dungeon.   -- If items equivalent, pick the one found on easier level.@@ -172,12 +173,13 @@         assert (itemsMatch item1 item2)                item2 -- keep the first found level   modifyState $ updateItemD $ EM.insertWith f iid item-  insertItemContainer iid k c+  insertItemContainer iid kit c +-- TODO: verify kit -- | Destroy some copies (possibly not all) of an item. updDestroyItem :: MonadStateWrite m-               => ItemId -> Item -> Int -> Container -> m ()-updDestroyItem iid item k c = assert (k > 0) $ do+               => ItemId -> Item -> ItemQuant -> Container -> m ()+updDestroyItem iid item (k, _) c = assert (k > 0) $ do   -- Do not remove the item from @sitemD@ nor from @sitemRev@,   -- It's incredibly costly and not noticeable for the player.   -- However, assert the item is registered in @sitemD@.@@ -214,8 +216,12 @@             => ItemId -> Int -> ActorId -> CStore -> CStore             -> m () updMoveItem iid k aid c1 c2 = assert (k > 0 && c1 /= c2) $ do-  deleteItemActor iid k aid c1-  insertItemActor iid k aid c2+  bag <- getsState $ getActorBag aid c1+  case iid `EM.lookup` bag of+    Nothing -> assert `failure` (iid, k, aid, c1, c2)+    Just (_, it) -> do+      deleteItemActor iid k aid c1+      insertItemActor iid (k, take k it) aid c2  -- TODO: optimize (a single call to updatePrio is enough) updAgeActor :: MonadStateWrite m => ActorId -> Delta Time -> m ()@@ -445,6 +451,18 @@       upd m = foldr f m sms   updateLevel lid $ updateSmell upd +updTimeItem :: MonadStateWrite m+            => ItemId -> Container -> ItemTimer -> ItemTimer+            -> m ()+updTimeItem iid c fromIt toIt = assert (fromIt /= toIt) $ do+  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+      insertItemContainer iid (k, toIt) c+    Nothing -> assert `failure` (bag, iid, c, fromIt, toIt)+ -- | Age the game. -- -- TODO: It leaks information that there is activity on various level,@@ -459,8 +477,7 @@ ageLevel delta lid =   updateLevel lid $ \lvl -> lvl {ltime = timeShift (ltime lvl) delta} -updRestart :: MonadStateWrite m-           => State -> m ()+updRestart :: MonadStateWrite m => State -> m () updRestart = putState  updRestartServer :: MonadStateWrite m => State -> m ()

@@ -31,6 +31,10 @@ updateFloor :: (ItemFloor -> ItemFloor) -> Level -> Level updateFloor f lvl = lvl {lfloor = f (lfloor lvl)} +-- | Update the items embedded in a tile on the level.+updateEmbed :: (ItemFloor -> ItemFloor) -> Level -> Level+updateEmbed f lvl = lvl {lembed = f (lembed lvl)}+ -- | Update the tile map. updateTile :: (TileMap -> TileMap) -> Level -> Level updateTile f lvl = lvl {ltile = f (ltile lvl)}@@ -56,64 +60,74 @@   modifyState $ updateFactionD $ EM.alter alt fid  insertItemContainer :: MonadStateWrite m-                    => ItemId -> Int -> Container -> m ()-insertItemContainer iid k c = case c of-  CFloor lid pos -> insertItemFloor iid k lid pos-  CActor aid store -> insertItemActor iid k aid store+                    => ItemId -> ItemQuant -> Container -> m ()+insertItemContainer iid kit c = case c of+  CFloor lid pos -> insertItemFloor iid kit lid pos+  CEmbed lid pos -> insertItemEmbed iid kit lid pos+  CActor aid store -> insertItemActor iid kit aid store   CTrunk{} -> return () +-- New @kit@ lands at the front of the list. insertItemFloor :: MonadStateWrite m-                => ItemId -> Int -> LevelId -> Point -> m ()-insertItemFloor iid k lid pos =-  let bag = EM.singleton iid k-      mergeBag = EM.insertWith (EM.unionWith (+)) pos bag+                => ItemId -> ItemQuant -> LevelId -> Point -> m ()+insertItemFloor iid kit lid pos =+  let bag = EM.singleton iid kit+      mergeBag = EM.insertWith (EM.unionWith mergeItemQuant) pos bag   in updateLevel lid $ updateFloor mergeBag +insertItemEmbed :: MonadStateWrite m+                => ItemId -> ItemQuant -> LevelId -> Point -> m ()+insertItemEmbed iid kit lid pos =+  let bag = EM.singleton iid kit+      mergeBag = EM.insertWith (EM.unionWith mergeItemQuant) pos bag+  in updateLevel lid $ updateEmbed mergeBag+ insertItemActor :: MonadStateWrite m-                => ItemId -> Int -> ActorId -> CStore -> m ()-insertItemActor iid k aid cstore = case cstore of+                => ItemId -> ItemQuant -> ActorId -> CStore -> m ()+insertItemActor iid kit aid cstore = case cstore of   CGround -> do     b <- getsState $ getActorBody aid-    insertItemFloor iid k (blid b) (bpos b)-  COrgan -> insertItemBody iid k aid-  CEqp -> insertItemEqp iid k aid-  CInv -> insertItemInv iid k aid+    insertItemFloor iid kit (blid b) (bpos b)+  COrgan -> insertItemBody iid kit aid+  CEqp -> insertItemEqp iid kit aid+  CInv -> insertItemInv iid kit aid   CSha -> do     b <- getsState $ getActorBody aid-    insertItemSha iid k (bfid b)+    insertItemSha iid kit (bfid b)  insertItemBody :: MonadStateWrite m-               => ItemId -> Int -> ActorId -> m ()-insertItemBody iid k aid = do-  let bag = EM.singleton iid k-      upd = EM.unionWith (+) bag+               => ItemId -> ItemQuant -> ActorId -> m ()+insertItemBody iid kit aid = do+  let bag = EM.singleton iid kit+      upd = EM.unionWith mergeItemQuant bag   updateActor aid $ \b -> b {borgan = upd (borgan b)}  insertItemEqp :: MonadStateWrite m-              => ItemId -> Int -> ActorId -> m ()-insertItemEqp iid k aid = do-  let bag = EM.singleton iid k-      upd = EM.unionWith (+) bag+              => ItemId -> ItemQuant -> ActorId -> m ()+insertItemEqp iid kit aid = do+  let bag = EM.singleton iid kit+      upd = EM.unionWith mergeItemQuant bag   updateActor aid $ \b -> b {beqp = upd (beqp b)}  insertItemInv :: MonadStateWrite m-              => ItemId -> Int -> ActorId -> m ()-insertItemInv iid k aid = do-  let bag = EM.singleton iid k-      upd = EM.unionWith (+) bag+              => ItemId -> ItemQuant -> ActorId -> m ()+insertItemInv iid kit aid = do+  let bag = EM.singleton iid kit+      upd = EM.unionWith mergeItemQuant bag   updateActor aid $ \b -> b {binv = upd (binv b)}  insertItemSha :: MonadStateWrite m-               => ItemId -> Int -> FactionId -> m ()-insertItemSha iid k fid = do-  let bag = EM.singleton iid k-      upd = EM.unionWith (+) bag+              => ItemId -> ItemQuant -> FactionId -> m ()+insertItemSha iid kit fid = do+  let bag = EM.singleton iid kit+      upd = EM.unionWith mergeItemQuant bag   updateFaction fid $ \fact -> fact {gsha = upd (gsha fact)}  deleteItemContainer :: MonadStateWrite m                     => ItemId -> Int -> Container -> m () deleteItemContainer iid k c = case c of   CFloor lid pos -> deleteItemFloor iid k lid pos+  CEmbed lid pos -> deleteItemEmbed iid k lid pos   CActor aid store -> deleteItemActor iid k aid store   CTrunk{} -> return () @@ -127,6 +141,16 @@                                    `twith` (iid, k, lid, pos)   in updateLevel lid $ updateFloor $ EM.alter rmFromFloor pos +deleteItemEmbed :: MonadStateWrite m+                => ItemId -> Int -> LevelId -> Point -> m ()+deleteItemEmbed iid k lid pos =+  let rmFromFloor (Just bag) =+        let nbag = rmFromBag k iid bag+        in if EM.null nbag then Nothing else Just nbag+      rmFromFloor Nothing = assert `failure` "item already removed"+                                   `twith` (iid, k, lid, pos)+  in updateLevel lid $ updateEmbed $ EM.alter rmFromFloor pos+ deleteItemActor :: MonadStateWrite m                 => ItemId -> Int -> ActorId -> CStore -> m () deleteItemActor iid k aid cstore = case cstore of@@ -156,13 +180,15 @@ deleteItemSha iid k fid = do   updateFaction fid $ \fact -> fact {gsha = rmFromBag k 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 =   let rfb Nothing = assert `failure` "rm from empty slot" `twith` (k, iid, bag)-      rfb (Just n) =+      rfb (Just (n, it)) =         case compare n k of           LT -> assert `failure` "rm more than there is"                        `twith` (n, k, iid, bag)           EQ -> Nothing-          GT -> Just (n - k)+          GT -> Just (n - k, drop k it)   in EM.alter rfb iid bag

@@ -16,7 +16,7 @@ import Game.LambdaHack.Atomic.CmdAtomic import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect+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,7 +28,7 @@ import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Content.ModeKind as ModeKind+import Game.LambdaHack.Content.ModeKind  -- All functions here that take an atomic action are executed -- in the state just before the action is executed.@@ -131,6 +131,7 @@   UpdLoseSmell lid sms -> do     let ps = map fst sms     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]@@ -159,8 +160,8 @@     (slid, sp) <- posOfAid source     (tlid, tp) <- posOfAid target     return $! assert (slid == tlid) $ PosSight slid [sp, tp]-  SfxProject aid _ -> singleAid aid-  SfxCatch aid _ -> singleAid aid+  SfxProject aid _ _ -> singleAid aid+  SfxCatch aid _ _ -> singleAid aid   SfxActivate aid _ _ -> singleAid aid   SfxCheck aid _ _ -> singleAid aid   SfxTrigger aid p _ -> do@@ -192,6 +193,7 @@  singleContainer :: MonadStateRead m => Container -> m PosAtomic singleContainer (CFloor lid p) = return $! PosSight lid [p]+singleContainer (CEmbed lid p) = return $! PosSight lid [p] singleContainer (CActor aid CSha) = do  -- shared stash is private   b <- getsState $ getActorBody aid   return $! PosFidAndSer (Just $ blid b) (bfid b)@@ -259,10 +261,8 @@            , UpdSpotActor target tb {bpos = bpos sb, boldpos = bpos tb} tais            ]   UpdMoveItem iid k aid cstore1 cstore2 | cstore1 == CSha  -- CSha is private-                                          || cstore2 == CSha -> do-    item <- getsState $ getItemBody iid-    return [ UpdLoseItem iid item k (CActor aid cstore1)-           , UpdSpotItem iid item k (CActor aid cstore2) ]+                                          || cstore2 == CSha ->+    containerMoveItem iid k (CActor aid cstore1) (CActor aid cstore2)   -- No need to cover @UpdSearchTile@, because if an actor sees only   -- one of the positions and so doesn't notice the search results,   -- he's left with a hidden tile, which doesn't cause any trouble@@ -276,9 +276,9 @@   SfxStrike source target _ _ -> do     -- Hack: make a fight detectable even if one of combatants not visible.     sb <- getsState $ getActorBody source-    return $! [ SfxEffect (bfid sb) source (Effect.RefillCalm (-1))+    return $! [ SfxEffect (bfid sb) source (IK.RefillCalm (-1))               | not $ bproj sb ]-              ++ [SfxEffect (bfid sb) target (Effect.RefillHP (-1))]+              ++ [SfxEffect (bfid sb) target (IK.RefillHP (-1))]   _ -> return [cmd]  -- | Messages for some unseen game object creation/destruction/alteration.@@ -327,9 +327,18 @@                 -> m [UpdAtomic] generalMoveItem iid k c1 c2 = do   case (c1, c2) of-    (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2 -> do+    (CActor aid1 cstore1, CActor aid2 cstore2) | aid1 == aid2 ->       return [UpdMoveItem iid k aid1 cstore1 cstore2]-    _ -> do+    _ -> containerMoveItem iid k c1 c2++containerMoveItem :: MonadStateRead m+                  => ItemId -> Int -> Container -> Container+                  -> m [UpdAtomic]+containerMoveItem iid k c1 c2 = do+  bag <- getsState $ getCBag c1+  case iid `EM.lookup` bag of+    Nothing -> assert `failure` (iid, k, c1, c2)+    Just (_, it) -> do       item <- getsState $ getItemBody iid-      return [ UpdLoseItem iid item k c1-             , UpdSpotItem iid item k c2 ]+      return [ UpdLoseItem iid item (k, take k it) c1+             , UpdSpotItem iid item (k, take k it) c2 ]

@@ -21,6 +21,7 @@ import Game.LambdaHack.Client.State import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.Faction+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Random

@@ -33,9 +33,9 @@ import Game.LambdaHack.Client.CommonClient import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State+import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest@@ -44,9 +44,11 @@ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point+import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.ItemKind as IK  -- | Require that the target enemy is visible by the party. condTgtEnemyPresentM :: MonadClient m => ActorId -> m Bool@@ -124,7 +126,7 @@   -- We do consider OFF weapons, because e.g., enemies might have turned   -- them off or they can be wrong for other party members, but are OK for us.   let lootIsWeapon =-        not $ null $ strongestSlot Effect.EqpSlotWeapon floorAssocs+        not $ null $ strongestSlot IK.EqpSlotWeapon floorAssocs   return $ lootIsWeapon  -- keep it lazy  -- | Check whether the actor has no weapon in equipment.@@ -132,23 +134,29 @@ condNoEqpWeaponM aid = do   allAssocs <- fullAssocsClient aid [CEqp]   -- We do not consider OFF weapons, because they apparently are not good.-  return $ null $ strongestSlot Effect.EqpSlotWeapon allAssocs+  return $ null $ strongestSlot IK.EqpSlotWeapon allAssocs     -- keep it lazy  -- | Require that the actor can project any items. condCanProjectM :: MonadClient m => ActorId -> m Bool condCanProjectM aid = do-  actorBlind <- radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight aid-  benList <- benAvailableItems aid permittedRanged [CEqp, CInv, CGround]-  let missiles = filter (maybe True ((< 0) . snd . snd) . fst . fst) benList-  return $ not actorBlind && not (null missiles)+  actorSk <- actorSkillsClient aid+  let skill = EM.findWithDefault 0 Ability.AbProject actorSk+      q _ itemFull b activeItems =+        either (const False) id+        $ permittedProject " " False skill itemFull b activeItems+  benList <- benAvailableItems aid q [CEqp, CInv, CGround]+  let missiles = filter (maybe True ((< 0) . snd) . fst . fst) benList+  return $ not (null missiles)     -- keep it lazy  -- | Produce the list of items with a given property available to the actor -- and the items' values. benAvailableItems :: MonadClient m-                  => ActorId -> (ItemFull -> Maybe Int -> Bool) -> [CStore]-                  -> m [( (Maybe (Int, (Int, Int)), (Int, CStore))+                  => ActorId+                  -> (Maybe Int -> ItemFull -> Actor -> [ItemFull] -> Bool)+                  -> [CStore]+                  -> m [( (Maybe (Int, Int), (Int, CStore))                         , (ItemId, ItemFull) )] benAvailableItems aid permitted cstores = do   cops <- getsState scops@@ -158,10 +166,10 @@   fact <- getsState $ (EM.! bfid b) . sfactionD   let ben cstore bag =         [ ((benefit, (k, cstore)), (iid, itemFull))-        | (iid, k) <- EM.assocs bag-        , let itemFull = itemToF iid k+        | (iid, kit@(k, _)) <- EM.assocs bag+        , let itemFull = itemToF iid kit         , let benefit = totalUsefulness cops b activeItems fact itemFull-        , permitted itemFull (fst <$> benefit)]+        , permitted (fst <$> benefit) itemFull b activeItems ]       benCStore cs = do         bag <- getsState $ getActorBag aid cs         return $! ben cs bag@@ -182,23 +190,28 @@   benItemL <- benGroundItems aid   return $ not $ null benItemL  -- keep it lazy --- | Produce the list of items on the ground beneath the actor.+-- | Produce the list of items on the ground beneath the actor+-- that are worth picking up. benGroundItems :: MonadClient m                => ActorId-               -> m [( (Maybe (Int, (Int, Int))+               -> m [( (Maybe (Int, Int)                      , (Int, CStore)), (ItemId, ItemFull) )] benGroundItems aid = do   b <- getsState $ getActorBody aid   canEscape <- factionCanEscape (bfid b)-  let desirableItem ItemFull{itemBase} use+  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-                      || Effect.Precious `elem` jfeature itemBase+                      || IK.Precious `elem` jfeature itemBase         | otherwise = use /= Just 0+                      && not (isNothing use  -- needs resources to id+                              && preciousWithoutSlot itemBase)   benAvailableItems aid desirableItem [CGround] --- | Require the actor is in a bad position to melee.--- We do not check if the actor has a weapon, because having--- no innate weapon is rare.+-- | 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@@ -224,7 +237,7 @@ condLightBetraysM aid = do   b <- getsState $ getActorBody aid   eqpItems <- map snd <$> fullAssocsClient aid [CEqp]-  let actorEqpShines = sumSlotNoFilter Effect.EqpSlotAddLight eqpItems > 0+  let actorEqpShines = sumSlotNoFilter IK.EqpSlotAddLight eqpItems > 0   aInAmbient<- getsState $ actorInAmbient b   return $! not aInAmbient     -- tile is dark, so actor could hide             && actorEqpShines  -- but actor betrayed by his equipped light

@@ -29,9 +29,7 @@ import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Frequency import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest@@ -46,9 +44,10 @@ 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 import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.TileKind as TileKind+import qualified Game.LambdaHack.Content.TileKind as TK  type ToAny a = Strategy (RequestTimed a) -> Strategy RequestAnyAbility @@ -89,8 +88,7 @@       condFastThreatAdj = any (\(_, (_, b)) -> bspeed b activeItems > speed1_5)                           $ takeWhile ((== 1) . fst) threatDistL       condCanFlee = not (null fleeL || condFastThreatAdj)-  mleader <- getsClient _sleader-  actorSk <- actorSkillsClient aid mleader+  actorSk <- actorSkillsClient aid   let stratToFreq :: MonadStateRead m                   => Int -> m (Strategy RequestAnyAbility)                   -> m (Frequency RequestAnyAbility)@@ -142,7 +140,7 @@       distant =         [ ( [AbProject]  -- for high-value target, shoot even in melee           , stratToFreq 2 $ (toAny :: ToAny AbProject)-            <$> ranged aid+            <$> projectItem aid           , condTgtEnemyPresent && condCanProject && not condOnTriggerable )         , ( [AbApply]           , stratToFreq 2 $ (toAny :: ToAny AbApply)@@ -169,9 +167,6 @@         , ( [AbMelee], (toAny :: ToAny AbMelee)             <$> meleeAny aid  -- avoid getting damaged for naught           , condAnyFoeAdj )-        , ( [AbMoveItem], (toAny :: ToAny AbMoveItem)-            <$> unEquipItems aid  -- late, because better to throw than unequip-          , True )         , ( [AbMove]             -- TODO: forget old target (e.g., tile), to start shooting,             -- unless can't shoot, etc.@@ -179,6 +174,9 @@           , condMeleeBad && condThreatNearby && (condNotCalmEnough                                                  || condThreatAtHand                                                  || condNoUsableWeapon) )+        , ( [AbMoveItem], (toAny :: ToAny AbMoveItem)+            <$> unEquipItems aid  -- late, because better to throw than unequip+          , True )         , ( [AbMove]           , chase aid False           , True )@@ -215,7 +213,7 @@ pickup aid onlyWeapon = do   benItemL <- benGroundItems aid   let isWeapon (_, (_, itemFull)) =-        maybe False ((== Effect.EqpSlotWeapon) . fst)+        maybe False ((== IK.EqpSlotWeapon) . fst)         $ strengthEqpSlot $ itemBase itemFull       filterWeapon | onlyWeapon = filter isWeapon                    | otherwise = id@@ -224,7 +222,6 @@   -- Pick up the best desirable item, if any.   case reverse $ sortBy (comparing cmp) $ filterWeapon benItemL of     ((_, (k, _)), (iid, itemFull)) : _ -> do-      updateItemSlot (Just aid) iid       b <- getsState $ getActorBody aid       -- TODO: instead of pickup to eqp and then move to inv, pickup to inv       let toCStore = if goesIntoInv (itemBase itemFull)@@ -263,18 +260,18 @@       -- items should be removed in yieldUnneeded earlier or soon after.       filterNeeded (_, itemFull) =         not $ unneeded cops condLightBetrays body activeItems fact itemFull-      bestThree = bestByEqpSlot (filter filterNeeded invAssocs)-                                (filter filterNeeded eqpAssocs)+      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-              $! msum $ map (improve CSha)-              $ map (\(_, (eqp, _, sha)) -> (sha, eqp)) bestThree+         then return $! bEqpSha          else return reject-    else return bEqpInv+    else return $! bEqpInv  unEquipItems :: MonadClient m              => ActorId -> m (Strategy (RequestTimed AbMoveItem))@@ -298,13 +295,13 @@            then Just $ ReqMoveItem iidEqp (itemK itemEqp) CEqp csha  -- share            else Nothing       yieldUnneeded = mapMaybe yieldSingleUnneeded eqpAssocs-      improve :: CStore -> ( Effect.EqpSlot+      improve :: CStore -> ( IK.EqpSlot                            , ( [(Int, (ItemId, ItemFull))]                              , [(Int, (ItemId, ItemFull))] ) )               -> Strategy (RequestTimed AbMoveItem)       improve fromCStore (slot, (bestInv, bestEqp)) =         case (bestInv, bestEqp) of-          _ | slot == Effect.EqpSlotPeriodic+          _ | slot == IK.EqpSlotPeriodic               && fromCStore == CEqp               && not (eqpOverfull body 0) ->             -- Don't get rid of periodic items from eqp unless eqp full.@@ -323,20 +320,19 @@       getK ((_, (_, itemFull)) : _) = itemK itemFull       betterThanInv _ [] = True       betterThanInv vEqp ((vInv, _) : _) = vEqp > vInv-      bestThree = bestByEqpSlot invAssocs eqpAssocs shaAssocs+      bestThree = bestByEqpSlot eqpAssocs invAssocs shaAssocs+      bInvSha = msum $ map (improve CInv)+                $ map (\((slot, _), (_, inv, sha)) ->+                        (slot, (sha, inv))) bestThree+      bEqpSha = msum $ map (improve CEqp)+                $ map (\((slot, _), (eqp, _, sha)) ->+                        (slot, (sha, eqp))) bestThree   case yieldUnneeded of-    [] ->-      if rsharedStash && calmEnough body activeItems-      then do-        let bInvSha = msum $ map (improve CInv)-                      $ map (\((slot, _), (_, inv, sha)) ->-                               (slot, (sha, inv))) bestThree-        if nullStrategy bInvSha-          then return $! msum $ map (improve CEqp)-                         $ map (\((slot, _), (eqp, _, sha)) ->-                                 (slot, (sha, eqp))) bestThree-          else return $! bInvSha-        else return reject+    [] -> 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@@ -347,7 +343,7 @@       return $! liftFrequency $ uniformFreq "yield unneeded" yieldUnneeded  groupByEqpSlot :: [(ItemId, ItemFull)]-               -> M.Map (Effect.EqpSlot, Text) [(ItemId, ItemFull)]+               -> M.Map (IK.EqpSlot, Text) [(ItemId, ItemFull)] groupByEqpSlot is =   let f (iid, itemFull) = case strengthEqpSlot $ itemBase itemFull of         Nothing -> Nothing@@ -358,37 +354,37 @@ bestByEqpSlot :: [(ItemId, ItemFull)]               -> [(ItemId, ItemFull)]               -> [(ItemId, ItemFull)]-              -> [((Effect.EqpSlot, Text)+              -> [((IK.EqpSlot, Text)                   , ( [(Int, (ItemId, ItemFull))]                     , [(Int, (ItemId, ItemFull))]                     , [(Int, (ItemId, ItemFull))] ) )]-bestByEqpSlot invAssocs eqpAssocs shaAssocs =+bestByEqpSlot eqpAssocs invAssocs shaAssocs =   let eqpMap = M.map (\g -> (g, [], [])) $ groupByEqpSlot eqpAssocs       invMap = M.map (\g -> ([], g, [])) $ groupByEqpSlot invAssocs       shaMap = M.map (\g -> ([], [], g)) $ groupByEqpSlot shaAssocs       appendThree (g1, g2, g3) (h1, h2, h3) = (g1 ++ h1, g2 ++ h2, g3 ++ h3)-      invEqpShaMap = M.unionsWith appendThree [invMap, eqpMap, shaMap]+      eqpInvShaMap = M.unionsWith appendThree [eqpMap, invMap, shaMap]       bestSingle eqpSlot g = strongestSlot eqpSlot g       bestThree (eqpSlot, _) (g1, g2, g3) = (bestSingle eqpSlot g1,                                              bestSingle eqpSlot g2,                                              bestSingle eqpSlot g3)-  in M.assocs $ M.mapWithKey bestThree invEqpShaMap+  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 Effect.EqpSlotAddLight itemFull)-       || 0 > fromMaybe 0 (strengthFromEqpSlot Effect.EqpSlotAddHurtMelee+   && (isJust (strengthFromEqpSlot IK.EqpSlotAddLight itemFull)+       || 0 > fromMaybe 0 (strengthFromEqpSlot IK.EqpSlotAddHurtMelee                                                itemFull)-       || 0 > fromMaybe 0 (strengthFromEqpSlot Effect.EqpSlotAddHurtRanged+       || 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 Effect.EqpSlotAddLight itemFull))+         && 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)@@ -399,12 +395,10 @@  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+  -- Items that are known and their effects are not stricly beneficial   -- should not be equipped (either they are harmful or they waste eqp space).   maybe False (\(u, _) -> u <= 0)     (totalUsefulness cops body activeItems fact itemFull)-  && (maybe True ((/= Effect.EqpSlotWeapon) . fst)-      $ strengthEqpSlot $ itemBase itemFull)  unneeded :: Kind.COps -> Bool -> Actor -> [ItemFull] -> Faction -> ItemFull          -> Bool@@ -417,8 +411,7 @@ meleeBlocker aid = do   b <- getsState $ getActorBody aid   fact <- getsState $ (EM.! bfid b) . sfactionD-  mleader <- getsClient _sleader-  actorSk <- actorSkillsClient aid mleader+  actorSk <- actorSkillsClient aid   mtgtMPath <- getsClient $ EM.lookup aid . stargetD   case mtgtMPath of     Just (_, Just (_ : q : _, (goal, _))) -> do@@ -462,6 +455,7 @@   let freq = uniformFreq "melee adjacent" $ concat mels   return $! liftFrequency freq +-- TODO: take charging status into account -- Fast monsters don't pay enough attention to features. trigger :: MonadClient m         => ActorId -> Bool -> m (Strategy (RequestTimed AbTrigger))@@ -472,31 +466,38 @@   b <- getsState $ getActorBody aid   activeItems <- activeItemsClient aid   fact <- getsState $ (EM.! bfid b) . sfactionD-  lvl <- getLevel $ blid b+  let lid = blid b+  lvl <- getLevel lid   unexploredD <- unexploredDepth   s <- getState-  per <- getPerFid $ blid b+  per <- getPerFid lid   let canSee = ES.member (bpos b) (totalVisible per)-      unexploredCurrent = ES.notMember (blid b) explored+      unexploredCurrent = ES.notMember lid explored       allExplored = ES.size explored == EM.size dungeon       t = lvl `at` bpos b-      feats = TileKind.tfeature $ okind t+      feats = TK.tfeature $ okind t       ben feat = case feat of-        F.Cause (Effect.Ascend k) ->  -- change levels sensibly, in teams+        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)+              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 unexploredD (signum k) (blid b)-                then 1000-                else if unexploredD (- signum k) (blid b)+                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 (blid b) (bpos b) k dungeon+              (lid2, pos2) = whereTo lid (bpos b) k dungeon               actorsThere = posToActors pos2 lid2 s           in if boldpos b == bpos b   -- probably used stairs last turn                 && boldlid b == lid2  -- in the opposite direction@@ -509,13 +510,13 @@                   in if fleeViaStairs                      then 1000 * eben + 1  -- strongly prefer correct direction                      else eben-        F.Cause ef@Effect.Escape{} -> do  -- flee via this way, too+        TK.Cause ef@IK.Escape{} -> do  -- 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-        F.Cause ef | not fleeViaStairs ->+        TK.Cause ef | not fleeViaStairs ->           effectToBenefit cops b activeItems fact ef         _ -> 0       benFeat = zip (map ben feats) feats@@ -524,45 +525,62 @@            | (benefit, feat) <- benFeat            , benefit > 0 ] -ranged :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbProject))-ranged aid = do+projectItem :: MonadClient m => ActorId -> m (Strategy (RequestTimed AbProject))+projectItem aid = do   btarget <- getsClient $ getTarget aid-  b@Actor{bpos, blid} <- getsState $ getActorBody aid-  mfpos <- aidTgtToPos aid blid btarget+  b@Actor{bpos} <- getsState $ getActorBody aid+  mfpos <- aidTgtToPos aid (blid b) btarget   seps <- getsClient seps   case (btarget, mfpos) of     (Just TEnemy{}, Just fpos) -> do-      actorBlind <- radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight aid       mnewEps <- makeLine b fpos seps       case mnewEps of-        Just newEps | not actorBlind -> do  -- ProjectBlind+        Just newEps -> do+          actorSk <- actorSkillsClient aid+          let skill = EM.findWithDefault 0 AbProject actorSk           -- ProjectAimOnself, ProjectBlockActor, ProjectBlockTerrain           -- and no actors or obstracles along the path.-          benList <- benAvailableItems aid permittedRanged [CEqp, CInv, CGround]+          let q _ itemFull b2 activeItems =+                either (const False) id+                $ permittedProject " " False skill itemFull b2 activeItems+          benList <- benAvailableItems aid q [CEqp, CInv, CGround]+          localTime <- getsState $ getLocalTime (blid b)           let coeff CGround = 2               coeff COrgan = 3  -- can't give to others               coeff CEqp = 1               coeff CInv = 1               coeff CSha = undefined  -- banned-              fRanged ((mben, (_, cstore)), (iid, ItemFull{itemBase})) =-                let trange = totalRange itemBase+              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+                    trange = totalRange itemBase                     bestRange = chessDist bpos fpos + 2  -- margin for fleeing                     rangeMult =  -- penalize wasted or unsafely low range                       10 + max 0 (10 - abs (trange - bestRange))-                    durableBonus = if Effect.Durable `elem` jfeature itemBase+                    durableBonus = if IK.Durable `elem` jfeature itemBase                                    then 2  -- we or foes keep it after the throw                                    else 1                     benR = durableBonus                            * coeff cstore                            * case mben of-                               Nothing -> -20  -- experimenting is fun-                               Just (_, (_, ben)) -> ben+                               Nothing -> -1  -- experiment if no options+                               Just (_, ben) -> ben+                           * (if recharged then 1 else 0)                 in if benR < 0 && trange >= chessDist bpos fpos                    then Just ( -benR * rangeMult `div` 10                              , ReqProject fpos newEps iid cstore )                    else Nothing               benRanged = mapMaybe fRanged benList-          return $! liftFrequency $ toFreq "ranged" benRanged+          return $! liftFrequency $ toFreq "projectItem" benRanged         _ -> return reject     _ -> return reject @@ -572,16 +590,19 @@ applyItem :: MonadClient m           => ActorId -> ApplyItemGroup -> m (Strategy (RequestTimed AbApply)) applyItem aid applyGroup = do-  actorBlind <- radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight aid-  let permitted itemFull@ItemFull{itemBase=item} _ =-        not (unknownPrecious itemFull)-        && if jsymbol item == '?' && actorBlind-           then False-           else Effect.Applicable `elem` jfeature item-  benList <- benAvailableItems aid permitted [CEqp, CInv, CGround]+  actorSk <- actorSkillsClient aid+  let skill = EM.findWithDefault 0 AbProject actorSk+      q _ itemFull b activeItems =+        either (const False) id+        $ permittedApply " " 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 (Effect.RefillHP p) _ | p > 0 = True+          let getP (IK.RefillHP p) _ | p > 0 = True+              getP (IK.OverfillHP p) _ | p > 0 = True               getP _ acc = acc           in case itemDisco itemFull of             Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->@@ -593,19 +614,46 @@       coeff CEqp = 1       coeff CInv = 1       coeff CSha = undefined  -- banned-      fTool ((mben, (_, cstore)), (iid, itemFull)) =-        let durableBonus = if Effect.Durable `elem` jfeature (itemBase itemFull)+      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                            then 5  -- we keep it after use                            else 1-            benR = durableBonus+            oldGrps = map (toGroupName . jname) organs+            createOrganAgain =+              -- This assumes the organ creation is beneficial. If it's+              -- a drawback of an otherwise good item, we should reverse+              -- the condition.+              let newGrps = strengthCreateOrgan itemFull+              in not $ null $ intersect newGrps oldGrps+            dropOrganVoid =+              -- This assumes the organ dropping is beneficial. If it's+              -- a drawback of an otherwise good item, or a marginal+              -- advantage only, we should reverse or ignore the condition.+              -- We ignore a very general @grp@ being used for a very+              -- common and easy to drop organ, etc.+              let newGrps = strengthDropOrgan itemFull+                  hasDropOrgan = not $ null newGrps+              in hasDropOrgan && null (intersect newGrps oldGrps)+            benR = case mben of+                     Nothing -> 0+                       -- experimenting is fun, but it's better to risk+                       -- foes' skin than ours -- TODO: when {activated}+                       -- is implemented, enable this for items too heavy,+                       -- etc. for throwing+                     Just (_, ben) -> ben+                   * (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-                   * case mben of-                       Nothing -> 0-                         -- experimenting is fun, but it's better to risk-                         -- foes' skin than ours -- TODO: when {activated}-                         -- is implemented, enable this for items too heavy,-                         -- etc. for throwing-                       Just (_, (_, ben)) -> ben         in if itemLegal itemFull            then if benR > 0                 then Just (benR, ReqApply iid cstore)@@ -633,7 +681,6 @@   b <- getsState $ getActorBody aid   lvl <- getLevel $ blid b   fact <- getsState $ (EM.! bfid b) . sfactionD-  mleader <- getsClient _sleader   let friendlyFid fid = fid == bfid b || isAllied fact fid   friends <- getsState $ actorRegularList friendlyFid (blid b)   allFoes <- getsState $ actorRegularAssocs (isAtWar fact) (blid b)@@ -645,7 +692,7 @@       nFrHere = nFriends b + 1       qualifyActor (aid2, body2) = do         activeItems <- activeItemsClient aid2-        dEnemy <- getsState $ dispEnemy aid mleader aid2 activeItems+        dEnemy <- getsState $ dispEnemy aid aid2 activeItems         let nFr = nFriends body2         return $! if displaceable body2 && dEnemy && nFr < nFrHere           then Just (nFr * nFr, bpos body2 `vectorToFrom` bpos b)@@ -690,7 +737,7 @@           Nothing -> do             tfact <- getsState $ (EM.! bfid b2) . sfactionD             activeItems <- activeItemsClient aid2-            dEnemy <- getsState $ dispEnemy aid mleader aid2 activeItems+            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@@ -758,7 +805,6 @@   let spos = bpos sb           -- source position       tpos = spos `shift` dir  -- target position       t = lvl `at` tpos-  mleader <- getsClient _sleader   -- We start by checking actors at the the target position,   -- which gives a partial information (actors can be invisible),   -- as opposed to accessibility (and items) which are always accurate@@ -769,7 +815,7 @@       -- @target@ can be a foe, as well as a friend.       tfact <- getsState $ (EM.! bfid b2) . sfactionD       activeItems <- activeItemsClient target-      dEnemy <- getsState $ dispEnemy source mleader target activeItems+      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))@@ -794,7 +840,7 @@         -- Movement requires full access.         return $! Just $ RequestAnyAbility $ ReqMove dir         -- The potential invisible actor is hit.-      else if not $ EM.null $ lvl `atI` tpos then+      else if EM.member tpos $ lfloor lvl then         -- This is, e.g., inaccessible open door with an item in it.         assert `failure` "AI causes AlterBlockItem" `twith` (run, source, dir)       else if not (Tile.isWalkable cotile t)  -- not implied

@@ -21,6 +21,7 @@ import Game.LambdaHack.Common.Frequency import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random@@ -82,6 +83,8 @@   case ours of     _ | -- Keep the leader: only a leader is allowed to pick another leader.         mleader /= Just oldAid+        -- Keep the leader: the faction forbids client leader change on level.+        || snd (autoDungeonLevel fact)         -- Keep the leader: he is on stairs and not stuck         -- and we don't want to clog stairs or get pushed to another level.         || not leaderStuck && Tile.isStair cotile t

@@ -3,6 +3,7 @@   ( targetStrategy, createPath   ) where +import Control.Applicative import Control.Exception.Assert.Sugar import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES@@ -19,11 +20,12 @@ import Game.LambdaHack.Common.Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Random@@ -31,6 +33,7 @@ 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 import Game.LambdaHack.Content.RuleKind @@ -95,7 +98,7 @@   -- and only if they can shoot at the moment)   canEscape <- factionCanEscape (bfid b)   explored <- getsClient sexplored-  smellRadius <- sumOrganEqpClient Effect.EqpSlotAddSmell aid+  smellRadius <- sumOrganEqpClient IK.EqpSlotAddSmell aid   let canSmell = smellRadius > 0       meleeNearby | canEscape = nearby `div` 2  -- not aggresive                   | otherwise = nearby@@ -113,13 +116,20 @@       nearbyFoes = filter (targetableEnemy . snd) allFoes       unknownId = ouniqGroup "unknown space"       itemUsefulness iid k =-        case totalUsefulness cops b activeItems fact (itemToF iid k) of-          Just (v, _) -> v-          Nothing -> 30  -- experimenting is fun+        fst <$> totalUsefulness cops b activeItems fact (itemToF iid k)+      -- TODO: factor out from here and benGroundItems       desirableItem iid item k-        | canEscape = itemUsefulness iid k /= 0-                           || Effect.Precious `elem` jfeature item-        | otherwise = itemUsefulness iid k /= 0+        | 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)       desirableBag bag = any (\(iid, k) ->                                desirableItem iid (itemD EM.! iid) k)                          $ EM.assocs bag@@ -254,6 +264,7 @@           pickNewTarget  -- prefer close foes to anything         TPoint lid pos -> do           let allExplored = ES.size explored == EM.size dungeon+          bag <- getsState $ getCBag $ CFloor lid 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.@@ -262,7 +273,7 @@              -- to equally interesting, but perhaps a bit closer targets,              -- most probably already targeted by other actors.              || (EM.findWithDefault 0 AbMoveItem actorSk <= 0  -- closestItems-                 || not (desirableBag (lvl `atI` pos)))+                 || not (desirableBag bag))                 && (not canSmell  -- closestSmell                     || pos == bpos b  -- in case server resends deleted smell                     || let sml = EM.findWithDefault timeZero pos (lsmell lvl)

@@ -10,122 +10,150 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Dice as Dice-import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind  -- | How much AI benefits from applying the effect. Multipllied by item p. -- Negative means harm to the enemy when thrown at him. Effects with zero -- benefit won't ever be used, neither actively nor passively. effectToBenefit :: Kind.COps -> Actor -> [ItemFull] -> Faction-                -> Effect.Effect Int -> Int+                -> IK.Effect -> Int effectToBenefit cops b activeItems fact eff =   let dungeonDweller = not $ fcanEscape $ gplayer fact   in case eff of-    Effect.NoEffect _ -> 0-    Effect.RefillHP p ->-      let hpMax = sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems+    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.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)-    Effect.Hurt d -> -(min 99 $ round (10 * Dice.meanDice d))-    Effect.RefillCalm p ->-      let calmMax = sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems+    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)+    IK.RefillCalm p ->+      let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems+      in if p > 0          then 1 + min p (fromIntegral $ (xM calmMax - bcalm b) `divUp` oneM)          else max (-20) p-    Effect.Dominate -> -200-    Effect.Impress -> -10-    Effect.CallFriend p -> 20 * p-    Effect.Summon{} | dungeonDweller -> 1 -- probably summons friends or crazies-    Effect.Summon{} -> 0                  -- probably generates enemies-    Effect.CreateItem p -> 20 * p-    Effect.ApplyPerfume -> -10-    Effect.Burn p -> -15 * p           -- usually splash damage, etc.-    Effect.Ascend{} -> 1               -- change levels sensibly, in teams-    Effect.Escape{} -> 10000           -- AI wants to win; spawners to guard-    Effect.Paralyze p -> -20 * p-    Effect.InsertMove p -> 50 * p-    Effect.DropBestWeapon -> -50-    Effect.DropEqp ' ' False -> -80-    Effect.DropEqp ' ' True -> -100-    Effect.DropEqp _ False -> -40-    Effect.DropEqp _ True -> -50-    Effect.SendFlying _ -> -10  -- but useful on self sometimes, too-    Effect.PushActor _ -> -10  -- but useful on self sometimes, too-    Effect.PullActor _ -> -10-    Effect.Teleport p | p < 5 -> 5 * p  -- blink to shoot at foe-    Effect.Teleport p | p < 10 -> 1  -- neither escape nor repositioning-    Effect.Teleport p -> -5 * p  -- get rid of the foe-    Effect.PolyItem _ -> 0  -- AI would loop-    Effect.Identify _ -> 0  -- AI would loop-    Effect.ActivateInv ' ' -> -100-    Effect.ActivateInv _ -> -50-    Effect.Explode _ -> -10-    Effect.OneOf _ -> 1  -- usually a mixed blessing, but slightly beneficial-    Effect.OnSmash _ -> -10-    Effect.TimedAspect k asp -> k * (aspectToBenefit cops b asp) `div` 50+    IK.OverfillCalm p ->+      let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems+      in if p > 0+         then 2 + min p (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.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+    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.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.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.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.Temporary _ -> 0 --- | Return the value to add to effect value and another to multiply it.-aspectToBenefit :: Kind.COps -> Actor -> Effect.Aspect Int -> Int+-- 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)+        in ( sacc + sum (map paspect $ IK.iaspects kind)+           , pacc + p )+  in ofoldrGroup t f (0, 0)++-- | Return the value to add to effect value.+aspectToBenefit :: Kind.COps -> Actor -> IK.Aspect Int -> Int aspectToBenefit _cops _b asp =   case asp of-    Effect.Periodic{} -> 0-    Effect.AddMaxHP p -> p * 10-    Effect.AddMaxCalm p -> p `divUp` 2-    Effect.AddSpeed p -> p * 10000-    Effect.AddSkills m -> 5 * sum (EM.elems m)-    Effect.AddHurtMelee p -> p `divUp` 3-    Effect.AddHurtRanged p -> p `divUp` 5-    Effect.AddArmorMelee p -> p `divUp` 5-    Effect.AddArmorRanged p -> p `divUp` 10-    Effect.AddSight p -> p * 10-    Effect.AddSmell p -> p * 2-    Effect.AddLight p -> p * 10+    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.AddHurtRanged p -> p `divUp` 5  -- TODO: should be summed with damage+    IK.AddArmorMelee p -> p `divUp` 5+    IK.AddArmorRanged p -> p `divUp` 10+    IK.AddSight p -> p * 10+    IK.AddSmell p -> p * 2+    IK.AddLight p -> p * 10  -- | Determine the total benefit from having an item in eqp or inv, -- according to item type, and also the benefit confered by equipping the item -- and from meleeing with it or applying it or throwing it. totalUsefulness :: Kind.COps -> Actor -> [ItemFull] -> Faction -> ItemFull-                -> Maybe (Int, (Int, Int))+                -> Maybe (Int, Int) totalUsefulness cops b activeItems fact itemFull =   let ben effects aspects =         let effBens = map (effectToBenefit cops b activeItems fact) effects             aspBens = map (aspectToBenefit cops b) aspects-            periodicEffBens =-              case strengthFromEqpSlot Effect.EqpSlotPeriodic itemFull of+            periodicEffBens = map (effectToBenefit cops b activeItems fact)+                                  (allRecharging effects)+            periodicBens =+              case strengthFromEqpSlot IK.EqpSlotPeriodic itemFull of                 Nothing -> []-                Just in100 -> map (\eff -> eff * in100 `div` 5) effBens-            selfBens = aspBens ++ periodicEffBens+                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             effSum = sum effBens             isWeapon =-              isJust (strengthFromEqpSlot Effect.EqpSlotWeapon itemFull)+              isJust (strengthFromEqpSlot IK.EqpSlotWeapon itemFull)             totalSum = if goesIntoInv $ itemBase itemFull                        then effSum-                       else if isWeapon-                            then effSum + eqpSum+                       else if isWeapon && effSum < 0+                            then - effSum + eqpSum                             else eqpSum-        in (totalSum, (eqpSum, effSum))+        in (totalSum, effSum)   in case itemDisco itemFull of     Just ItemDisco{itemAE=Just ItemAspectEffect{jaspects, jeffects}} ->       Just $ ben jeffects jaspects-    Just ItemDisco{itemKind=ItemKind{iaspects, ieffects}} ->+    Just ItemDisco{itemKind=IK.ItemKind{iaspects, ieffects}} ->       let travA x =-            St.evalState (Effect.aspectTrav x (return . round . Dice.meanDice))+            St.evalState (IK.aspectTrav x (return . round . Dice.meanDice))                          ()           jaspects = map travA iaspects-          travE x =-            St.evalState (Effect.effectTrav x (return . round . Dice.meanDice))-                         ()-          jeffects = map travE ieffects-      in Just $ ben jeffects jaspects+      in Just $ ben ieffects jaspects     _ -> Nothing

@@ -9,13 +9,11 @@ #endif   ) where -import Control.Arrow (second) import Control.Exception.Assert.Sugar import Data.Binary import Data.Bits (Bits, complement, (.&.), (.|.)) import Data.List import Data.Maybe-import qualified Data.Sequence as Seq  import Game.LambdaHack.Common.Point import qualified Game.LambdaHack.Common.PointArray as PointArray@@ -38,48 +36,65 @@ apartBfs :: BfsDistance apartBfs = pred minKnownBfs +-- TODO: costly; peephole optimize, optmize BFS, don't call so often -- | Fill out the given BFS array. fillBfs :: (Point -> Point -> MoveLegal)  -- ^ is a move from known tile legal         -> (Point -> Point -> Bool)       -- ^ is a move from unknown legal         -> Point                          -- ^ starting position         -> PointArray.Array BfsDistance   -- ^ initial array, with @apartBfs@         -> PointArray.Array BfsDistance   -- ^ array with calculated distances+{-# INLINE fillBfs #-} fillBfs isEnterable passUnknown origin aInitial =-  let maxUnknownBfs = pred apartBfs-      maxKnownBfs = pred maxBound-      bfs :: Seq.Seq (Point, BfsDistance)+  let maxKnownBfs = pred maxBound+      predMaxKnownBfs = pred maxKnownBfs+      bfs :: BfsDistance+          -> [Point]+          -> [Point]           -> PointArray.Array BfsDistance           -> PointArray.Array BfsDistance-      bfs q a =-        case Seq.viewr q of-          Seq.EmptyR -> a  -- no more positions to check-          _ Seq.:> (_, d)-            | d == maxUnknownBfs || d == maxKnownBfs -> a  -- too far-          q1 Seq.:> (pos, oldDistance) | oldDistance >= minKnownBfs ->-            let distance = succ oldDistance-                allMvs = map (shift pos) moves-                freshMv p = a PointArray.! p == apartBfs-                freshMvs = filter freshMv allMvs-                legal p = (p, isEnterable pos p)-                legalities = map legal freshMvs-                notBlocked = filter ((/= MoveBlocked) . snd) legalities-                legalToDist l = if l == MoveToOpen-                                then distance-                                else distance .&. complement minKnownBfs-                mvs = map (second legalToDist) notBlocked-                q2 = foldr (Seq.<|) q1 mvs-                s2 = a PointArray.// mvs-            in bfs q2 s2-          q1 Seq.:> (pos, oldDistance) ->-            let distance = succ oldDistance-                allMvs = map (shift pos) moves-                goodMv p = a PointArray.! p == apartBfs && passUnknown pos p-                mvs = zip (filter goodMv allMvs) (repeat distance)-                q2 = foldr (Seq.<|) q1 mvs-                s2 = a PointArray.// mvs-            in bfs q2 s2-      origin0 = (origin, minKnownBfs)-  in bfs (Seq.singleton origin0) (aInitial PointArray.// [origin0])+      bfs distance predK predU a =+        let distCompl = distance .&. complement minKnownBfs+            processKnown (succK2, succU2, a2) pos =+              let fKnown (lK, lU) move =+                    let p = shift pos move+                        freshMv = a2 PointArray.! p == apartBfs+                        legality = isEnterable pos p+                        (notBlocked, enteredUnknown) = case legality of+                          MoveBlocked -> (False, undefined)+                          MoveToOpen -> (True, False)+                          MoveToUnknown -> (True, True)+                    in if freshMv && notBlocked+                       then if enteredUnknown+                            then (lK, p : lU)+                            else (p : lK, lU)+                       else (lK, lU)+                  (mvsK, mvsU) = foldl' fKnown ([], []) moves+                  upd = zip mvsK (repeat distance)+                        ++ zip mvsU (repeat distCompl)+                  !a3 = a2 PointArray.// upd+              in (mvsK ++ succK2, mvsU ++ succU2, a3)+            processUnknown (succU2, a2) pos =+              let fUnknown lU move =+                    let p = shift pos move+                        freshMv = a2 PointArray.! p == apartBfs+                        notBlocked = passUnknown pos p+                    in if freshMv && notBlocked+                       then p : lU+                       else lU+                  mvsU = foldl' fUnknown [] moves+                  upd = zip mvsU (repeat distCompl)+                  !a3 = a2 PointArray.// 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)])  -- TODO: Use http://harablog.wordpress.com/2011/09/07/jump-point-search/ -- to determine a few really different paths and compare them,@@ -94,6 +109,7 @@             -> (Point -> Point -> Bool)             -> Point -> Point -> Int -> PointArray.Array BfsDistance             -> Maybe [Point]+{-# INLINE findPathBfs #-} findPathBfs isEnterable passUnknown source target sepsRaw bfs =   assert (bfs PointArray.! source == minKnownBfs) $   let targetDist = bfs PointArray.! target

@@ -22,7 +22,6 @@ import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level@@ -33,7 +32,7 @@ import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Content.TileKind (TileKind)  -- | Get cached BFS data and path or, if not stored, generate, -- store and return. Due to laziness, they are not calculated until needed.@@ -42,22 +41,28 @@                    -> m (PointArray.Array BfsDistance, Maybe [Point]) getCacheBfsAndPath aid target = do   seps <- getsClient seps+  b <- getsState $ getActorBody aid+  let origin = bpos b+  (isEnterable, passUnknown) <- condBFS aid   let pathAndStore :: PointArray.Array BfsDistance                    -> m (PointArray.Array BfsDistance, Maybe [Point])       pathAndStore bfs = do-        computePath <- computePathBFS aid-        let mpath = computePath target seps bfs+        let mpath = findPathBfs isEnterable passUnknown origin target seps bfs         modifyClient $ \cli ->           cli {sbfsD = EM.insert aid (bfs, target, seps, mpath) (sbfsD cli)}         return (bfs, mpath)   mbfs <- getsClient $ EM.lookup aid . sbfsD   case mbfs of-    Just (bfs, targetOld, sepsOld, mpath) | targetOld == target-                                            && sepsOld == seps ->-      return (bfs, mpath)-    Just (bfs, _, _, _) -> pathAndStore bfs-    Nothing -> do-      bfs <- computeBFS aid+    Just (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+      Level{lxsize, lysize} <- getLevel $ blid b+      let vInitial = PointArray.replicateA lxsize lysize apartBfs+          bfs = fillBfs isEnterable passUnknown origin vInitial       pathAndStore bfs  getCacheBfs :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)@@ -68,33 +73,12 @@     Just (bfs, _, _, _) -> return bfs     Nothing -> fmap fst $ getCacheBfsAndPath aid (Point 0 0) -computeBFS :: MonadClient m => ActorId -> m (PointArray.Array BfsDistance)-computeBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do-  b <- getsState $ getActorBody aid-  Level{lxsize, lysize} <- getLevel $ blid b-  let origin = bpos b-      vInitial = PointArray.replicateA lxsize lysize apartBfs-  -- Here we don't want '$!', because we want the BFS data lazy.-  return ${-keep it!-} fillBfs isEnterable passUnknown origin vInitial--computePathBFS :: MonadClient m-               => ActorId-               -> m (Point -> Int -> PointArray.Array BfsDistance-                     -> Maybe [Point])-computePathBFS = computeAnythingBFS $ \isEnterable passUnknown aid -> do-  b <- getsState $ getActorBody aid-  let origin = bpos b-  -- Here we don't want '$!', because we want the BFS data lazy.-  return ${-keep it!-} findPathBfs isEnterable passUnknown origin--computeAnythingBFS :: MonadClient m-                   => ((Point -> Point -> MoveLegal)-                       -> (Point -> Point -> Bool)-                       -> ActorId-                       -> m a)-                   -> ActorId-                   -> m a-computeAnythingBFS fAnything aid = do+condBFS :: MonadClient m+        => ActorId+        -> m (Point -> Point -> MoveLegal,+              Point -> Point -> Bool)+{-# INLINE condBFS #-}+condBFS aid = do   cops@Kind.COps{cotile=cotile@Kind.Ops{ouniqGroup}} <- getsState scops   b <- getsState $ getActorBody aid   -- We assume the actor eventually becomes a leader (or has the same@@ -114,6 +98,7 @@       conditions = catMaybes $ chAccess : chDoorAccess       -- Legality of move from a known tile, assuming doors freely openable.       isEnterable :: Point -> Point -> MoveLegal+      {-# INLINE isEnterable #-}       isEnterable spos tpos =         let st = lvl `at` spos             tt = lvl `at` tpos@@ -129,13 +114,14 @@                 else MoveBlocked       -- Legality of move from an unknown tile, assuming unknown are open.       passUnknown :: Point -> Point -> Bool+      {-# INLINE passUnknown #-}       passUnknown = case chAccess of  -- spos is unknown, so not a door         Nothing -> \_ tpos -> let tt = lvl `at` tpos                               in tt == unknownId         Just ch -> \spos tpos -> let tt = lvl `at` tpos                                  in tt == unknownId                                     && ch spos tpos-  fAnything isEnterable passUnknown aid+  return (isEnterable, passUnknown)  accessCacheBfs :: MonadClient m => ActorId -> Point -> m (Maybe Int) {-# INLINE accessCacheBfs #-}@@ -229,35 +215,46 @@ closestTriggers onlyDir exploredToo aid = do   Kind.COps{cotile} <- getsState scops   body <- getsState $ getActorBody aid-  lvl <- getLevel $ blid body+  let lid = blid body+  lvl <- getLevel lid   dungeon <- getsState sdungeon   explored <- getsClient sexplored   unexploredD <- unexploredDepth   let allExplored = ES.size explored == EM.size dungeon-      unexUp = onlyDir /= Just False && unexploredD 1 (blid body)-      unexDown = onlyDir /= Just True && unexploredD (-1) (blid body)-      unexEffect (Effect.Ascend p) = if p > 0 then unexUp else unexDown-      unexEffect _ =-        -- Escape (or guard) only after exploring, for high score, etc.-        allExplored-      isTrigger-        | exploredToo = \t -> Tile.isWalkable cotile t-                              && not (null $ Tile.causeEffects cotile t)-        | otherwise = \t -> Tile.isWalkable cotile t-                            && any unexEffect (Tile.causeEffects cotile t)-      f :: [Point] -> Point -> Kind.Id TileKind -> [Point]-      f acc p t = if isTrigger t then p : acc else acc+      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+                 in map (,p) (filter g l) ++ acc+        else acc   let triggersAll = PointArray.ifoldlA f [] $ ltile lvl       -- Don't target stairs under the actor. Most of the time they       -- are blocked and stay so, so we seek other stairs, if any.       -- If no other stairs in this direction, let's wait here.-      triggers | length triggersAll > 1 = delete (bpos body) triggersAll+      triggers | length triggersAll > 1 =+                 filter ((/= bpos body) . snd) triggersAll                | otherwise = triggersAll   case triggers of     [] -> return []     _ -> do       bfs <- getCacheBfs aid-      let ds = mapMaybe (\p -> fmap (,p) (accessBfs bfs p)) 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  unexploredDepth :: MonadClient m => m (Int -> LevelId -> Bool)

@@ -22,7 +22,7 @@ import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect+import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest@@ -161,19 +161,18 @@             then Nothing  -- ProjectBlockActor, ProjectAimOnself             else tryLines epsOld (Nothing, minBound) -actorSkillsClient :: MonadClient m-                  => ActorId -> Maybe ActorId -> m Ability.Skills-actorSkillsClient aid mleader = do+actorSkillsClient :: MonadClient m => ActorId -> m Ability.Skills+actorSkillsClient aid = do   activeItems <- activeItemsClient aid-  getsState $ actorSkills aid mleader activeItems+  -- Newest Leader in _sleader, not yet in sfactionD.+  mleader <- getsClient _sleader+  getsState $ actorSkills mleader aid activeItems  maxActorSkillsClient :: MonadClient m                      => ActorId -> m Ability.Skills maxActorSkillsClient aid = do   activeItems <- activeItemsClient aid-  skOther <- getsState $ actorSkills aid Nothing activeItems-  skLeader <- getsState $ actorSkills aid (Just aid) activeItems-  return $! Ability.maxSkills skOther skLeader+  getsState $ maxActorSkills aid activeItems  updateItemSlot :: MonadClient m => Maybe ActorId -> ItemId -> m () updateItemSlot maid iid = do@@ -209,7 +208,7 @@   activeAssocs <- fullAssocsClient aid [CEqp, COrgan]   return $! map snd activeAssocs -itemToFullClient :: MonadClient m => m (ItemId -> Int -> ItemFull)+itemToFullClient :: MonadClient m => m (ItemId -> ItemQuant -> ItemFull) itemToFullClient = do   cops <- getsState scops   discoKind <- getsClient sdiscoKind@@ -226,11 +225,15 @@ pickWeaponClient source target = do   eqpAssocs <- fullAssocsClient source [CEqp]   bodyAssocs <- fullAssocsClient source [COrgan]-  mleader <- getsClient _sleader-  actorSk <- actorSkillsClient source mleader+  actorSk <- actorSkillsClient source+  sb <- getsState $ getActorBody source   let allAssocs = eqpAssocs ++ bodyAssocs-  case filter (not . unknownPrecious . snd . snd)-       $ strongestSlotNoFilter Effect.EqpSlotWeapon allAssocs of+      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 []     iis@((maxS, _) : _) -> do@@ -242,7 +245,7 @@       return $! [ReqMelee target iid cstore]  sumOrganEqpClient :: MonadClient m-                  => Effect.EqpSlot -> ActorId -> m Int+                  => IK.EqpSlot -> ActorId -> m Int sumOrganEqpClient eqpSlot aid = do   activeItems <- activeItemsClient aid   return $! sumSlotNoFilter eqpSlot activeItems

@@ -10,6 +10,7 @@ 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@@ -19,7 +20,6 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.Kind as Kind@@ -31,8 +31,9 @@ import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Content.ItemKind-import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Content.ItemKind (ItemKind)+import qualified Game.LambdaHack.Content.ItemKind as IK+import qualified Game.LambdaHack.Content.TileKind as TK  -- * RespUpdAtomicAI @@ -64,11 +65,11 @@         -- to @toTile@. See @updAlterTile@.         let subject = ""  -- a hack, we we don't handle adverbs well             verb = "turn into"-            msg = makeSentence [ "the", MU.Text $ tname $ okind t-                               , "at position", MU.Text $ tshow p+            msg = makeSentence [ "the", MU.Text $ TK.tname $ okind t+                               , "at position", MU.Text $ T.pack $ show p                                , "suddenly"  -- adverb                                , MU.SubjectVerbSg subject verb-                               , MU.AW $ MU.Text $ tname $ okind toTile ]+                               , MU.AW $ MU.Text $ TK.tname $ okind toTile ]         return [ cmd  -- reveal the tile                , UpdMsgAll msg  -- show the message                ]@@ -211,18 +212,21 @@           else Just $ UpdLoseActor aid b ais         outActor = mapMaybe fActor outPrio     -- Wipe out remembered items on tiles that now came into view.-    Level{lfloor, lsmell} <- getLevel lid-    let inFov = totalVisible perNew ES.\\ totalVisible perOld+    lvl <- getLevel lid+    let inFov = ES.elems $ totalVisible perNew ES.\\ totalVisible perOld         pMaybe p = maybe Nothing (\x -> Just (p, x))-        inFloor = mapMaybe (\p -> pMaybe p $ EM.lookup p lfloor)-                           (ES.elems inFov)-        fItem p (iid, k) = UpdLoseItem iid (getItemBody iid s) k (CFloor lid p)-        fBag (p, bag) = map (fItem p) $ EM.assocs bag-        inItem = concatMap fBag inFloor+        inContainer fc itemFloor =+          let inItem = mapMaybe (\p -> pMaybe p $ EM.lookup p itemFloor) inFov+              fItem p (iid, kit) =+                UpdLoseItem iid (getItemBody iid s) kit (fc lid p)+              fBag (p, bag) = map (fItem p) $ EM.assocs bag+          in concatMap fBag inItem+        inFloor = inContainer CFloor (lfloor lvl)+        inEmbed = inContainer CEmbed (lembed lvl)     -- Remembered map tiles not wiped out, due to optimization in @updSpotTile@.     -- Wipe out remembered smell on tiles that now came into smell Fov.     let inSmellFov = smellVisible perNew ES.\\ smellVisible perOld-        inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p lsmell)+        inSm = mapMaybe (\p -> pMaybe p $ EM.lookup p (lsmell lvl))                         (ES.elems inSmellFov)         inSmell = if null inSm then [] else [UpdLoseSmell lid inSm]     let seenNew = seenAtomicCli False fid perNew@@ -233,18 +237,19 @@     assert (allB seenOld psActor) skip     -- Verify that we forget only currently invisible actors.     assert (allB (not . seenNew) psActor) skip-    psItemSmell <- mapM posUpdAtomic $ inItem ++ inSmell+    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     -- Verify that we forget only currently seen items and smell.     assert (allB seenNew psItemSmell) skip-    return $! cmd : outActor ++ inItem ++ inSmell+    return $! cmd : outActor ++ inTileSmell   _ -> return [cmd]  deleteSmell :: MonadClient m => ActorId -> Point -> m [UpdAtomic] deleteSmell aid pos = do   b <- getsState $ getActorBody aid-  smellRadius <- sumOrganEqpClient Effect.EqpSlotAddSmell aid+  smellRadius <- sumOrganEqpClient IK.EqpSlotAddSmell aid   if smellRadius <= 0 then return []   else do     lvl <- getLevel $ blid b

@@ -22,7 +22,7 @@ import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.Level+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.State  newtype SlotChar = SlotChar {slotChar :: Char}@@ -42,6 +42,7 @@   sectionBy (sort ls) Nothing  where   succSlot c d = ord (slotChar d) - ord (slotChar c) == 1+  succ2Slot c d = ord (slotChar d) - ord (slotChar c) == 2    sectionBy []     Nothing       = T.empty   sectionBy []     (Just (c, d)) = finish (c,d)@@ -52,6 +53,9 @@    finish (c, d) | c == d         = T.pack [slotChar c]                 | succSlot c d   = T.pack [slotChar c, slotChar d]+                | succ2Slot c d  = T.pack [ slotChar c+                                          , chr (1 + ord (slotChar c))+                                          , slotChar d ]                 | otherwise      = T.pack [slotChar c, '-', slotChar d]  allSlots :: [SlotChar]@@ -72,11 +76,11 @@   candidates = take (length allSlots)                $ drop (1 + fromJust (elemIndex lastSlot allSlots))                $ cycle allSlots-  onPerson = maybe (sharedAllOwnedFid fid s)-                   (\body -> sharedAllOwned body s)+  onPerson = maybe (sharedAllOwnedFid True fid s)+                   (\body -> sharedAllOwned True body s)                    mbody   onGroud = maybe EM.empty-                  (\body -> sdungeon s EM.! blid body `atI` bpos body)+                  (\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

@@ -4,7 +4,7 @@   ( Key(..), showKey, handleDir, dirAllKey   , moveBinding, mkKM, keyTranslate   , Modifier(..), KM(..), showKM-  , escKM, spaceKM, pgupKM, pgdnKM+  , escKM, spaceKM, returnKM, pgupKM, pgdnKM   ) where  import Control.Exception.Assert.Sugar@@ -34,6 +34,8 @@   | Down   | End   | Begin+  | Insert+  | Delete   | Home   | KP !Char      -- ^ a keypad key for a character (digits and operators)   | Char !Char    -- ^ a single printable character@@ -76,6 +78,8 @@ showKey PgUp     = "PGUP" showKey PgDn     = "PGDOWN" showKey Begin    = "BEGIN"+showKey Insert   = "INSERT"+showKey Delete   = "DELETE" showKey (KP c)   = "KEYPAD_" <> T.singleton c showKey (Unknown s) = s @@ -90,6 +94,9 @@ spaceKM :: KM spaceKM = KM {modifier = NoModifier, key = Space} +returnKM :: KM+returnKM = KM {modifier = NoModifier, key = Return}+ pgupKM :: KM pgupKM = KM {modifier = NoModifier, key = PgUp} @@ -120,18 +127,34 @@ dirViShiftKey :: [Key] dirViShiftKey = map (Char . Char.toUpper) dirViChar +dirMoveNoModifier :: Bool -> Bool -> [Key]+dirMoveNoModifier configVi configLaptop =+  dirKeypadKey ++ if configVi then dirViKey+                  else if configLaptop then dirLaptopKey+                  else []++dirRunNoModifier :: Bool -> Bool -> [Key]+dirRunNoModifier configVi configLaptop =+  dirKeypadShiftKey ++ if configVi then dirViShiftKey+                       else if configLaptop then dirLaptopShiftKey+                       else []++dirRunControl :: [Key]+dirRunControl = dirKeypadKey+                ++ dirKeypadShiftKey+                ++ (map Char dirKeypadShiftChar)+ dirAllKey :: Bool -> Bool -> [Key]-dirAllKey configVi configLaptop = dirKeypadKey ++ if configVi-                                                  then dirViKey-                                                  else if configLaptop-                                                       then dirLaptopKey-                                                       else []+dirAllKey configVi configLaptop =+  dirMoveNoModifier configVi configLaptop+  ++ dirRunNoModifier configVi configLaptop+  ++ dirRunControl  -- | Configurable event handler for the direction keys. -- Used for directed commands such as close door. handleDir :: Bool -> Bool -> KM -> (Vector -> a) -> a -> a handleDir configVi configLaptop KM{modifier=NoModifier, key} h k =-  let assocs = zip (dirAllKey configVi configLaptop) $ moves ++ moves+  let assocs = zip (dirAllKey configVi configLaptop) $ cycle moves   in maybe k h (lookup key assocs) handleDir _ _ _ _ k = k @@ -144,19 +167,9 @@         map (assign move) (zip (zipWith KM (repeat modifier) keys) moves)       mapRun modifier keys =         map (assign run) (zip (zipWith KM (repeat modifier) keys) moves)-      dirOtherKey | configVi = dirViKey-                  | configLaptop = dirLaptopKey-                  | otherwise = []-      dirOtherShiftKey | configVi = dirViShiftKey-                       | configLaptop = dirLaptopShiftKey-                       | otherwise = []-  in mapMove NoModifier dirKeypadKey-     ++ mapMove NoModifier dirOtherKey-     ++ mapRun NoModifier dirKeypadShiftKey-     ++ mapRun NoModifier dirOtherShiftKey-     ++ mapRun Control dirKeypadKey-     ++ mapRun Control dirKeypadShiftKey-     ++ mapRun Control (map Char dirKeypadShiftChar)+  in mapMove NoModifier (dirMoveNoModifier configVi configLaptop)+     ++ mapRun NoModifier (dirRunNoModifier configVi configLaptop)+     ++ mapRun Control dirRunControl  mkKM :: String -> KM mkKM s = let mkKey sk =@@ -205,17 +218,36 @@ keyTranslate "Tab"           = Tab keyTranslate "ISO_Left_Tab"  = BackTab keyTranslate "BackSpace"     = BackSpace+keyTranslate "Up"            = Up keyTranslate "KP_Up"         = Up+keyTranslate "Down"          = Down keyTranslate "KP_Down"       = Down+keyTranslate "Left"          = Left keyTranslate "KP_Left"       = Left+keyTranslate "Right"         = Right keyTranslate "KP_Right"      = Right+keyTranslate "Home"          = Home keyTranslate "KP_Home"       = Home+keyTranslate "End"           = End keyTranslate "KP_End"        = End keyTranslate "Page_Up"       = PgUp keyTranslate "KP_Page_Up"    = PgUp+keyTranslate "Prior"         = PgUp+keyTranslate "KP_Prior"      = PgUp keyTranslate "Page_Down"     = PgDn keyTranslate "KP_Page_Down"  = PgDn+keyTranslate "Next"          = PgDn+keyTranslate "KP_Next"       = PgDn+keyTranslate "Begin"         = Begin keyTranslate "KP_Begin"      = Begin+keyTranslate "Clear"         = Begin+keyTranslate "KP_Clear"      = Begin+keyTranslate "Center"        = Begin+keyTranslate "KP_Center"     = Begin+keyTranslate "Insert"        = Insert+keyTranslate "KP_Insert"     = Insert+keyTranslate "Delete"        = Delete+keyTranslate "KP_Delete"     = Delete keyTranslate "KP_Enter"      = Return keyTranslate ['K','P','_',c] = KP c keyTranslate [c]             = Char c

@@ -3,7 +3,7 @@ module Game.LambdaHack.Client.State   ( StateClient(..), defStateClient, defaultHistory   , updateTarget, getTarget, updateLeader, sside-  , PathEtc, TgtMode(..), RunParams(..), LastRecord+  , PathEtc, TgtMode(..), RunParams(..), LastRecord, EscAI(..)   , toggleMarkVision, toggleMarkSmell, toggleMarkSuspect   ) where @@ -36,6 +36,7 @@ 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@@ -70,6 +71,8 @@   , srandom      :: !R.StdGen      -- ^ current random generator   , slastRecord  :: !LastRecord    -- ^ state of key sequence recording   , slastPlay    :: ![K.KM]        -- ^ state of key sequence playback+  , slastLost    :: !(ES.EnumSet ActorId)+                                   -- ^ actors that just got out of sight   , swaitTimes   :: !Int           -- ^ player just waited this many times   , _sleader     :: !(Maybe ActorId)                                    -- ^ current picked party leader@@ -82,7 +85,8 @@   , scurDifficulty :: !Int         -- ^ current game difficulty level   , sslots       :: !ItemSlots     -- ^ map from slots to items   , slastSlot    :: !SlotChar      -- ^ last used slot-  , sgameMode    :: !GroupName     -- ^ current game mode+  , sgameMode    :: !(GroupName ModeKind)  -- ^ current game mode+  , sescAI       :: !EscAI         -- ^ just canceled AI control with ESC   , sdebugCli    :: !DebugModeCli  -- ^ client debugging mode   }   deriving Show@@ -109,6 +113,9 @@                   , Int     -- commands left to record for this batch                   ) +data EscAI = EscAINothing | EscAIStarted | EscAIMenu | EscAIExited+  deriving (Show, Eq)+ -- | Initial game client state. defStateClient :: History -> Report -> FactionId -> Bool -> StateClient defStateClient shistory sreport _sside sisAI =@@ -133,6 +140,7 @@     , srandom = R.mkStdGen 42  -- will be set later     , slastRecord = ([], [], 0)     , slastPlay = []+    , slastLost = ES.empty     , swaitTimes = 0     , _sleader = Nothing  -- no heroes yet alive     , _sside@@ -144,7 +152,8 @@     , scurDifficulty = difficultyDefault     , sslots = (EM.empty, IM.empty)     , slastSlot = SlotChar 'a'-    , sgameMode = "campaign"+    , sgameMode = "starting"+    , sescAI = EscAINothing     , sdebugCli = defDebugModeCli     } @@ -152,7 +161,7 @@ defaultHistory = do   dateTime <- getClockTime   let curDate = MU.Text $ T.pack $ calendarTimeToString $ toUTCTime dateTime-  return $! singletonHistory $ singletonReport+  return $! singletonHistory timeZero $ singletonReport          $! makeSentence ["Human history log started on", curDate]  -- | Update target parameters within client state.@@ -248,8 +257,10 @@         srandom = read g         slastRecord = ([], [], 0)         slastPlay = []+        slastLost = ES.empty         swaitTimes = 0         squit = False+        sescAI = EscAINothing     return $! StateClient{..}  instance Binary RunParams where

@@ -20,6 +20,7 @@ import Control.Exception.Assert.Sugar import Control.Monad import qualified Data.EnumMap.Strict as EM+import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M import Data.Maybe @@ -92,7 +93,7 @@   -- For human UI we invalidate whole @sbfsD@ at the start of each   -- UI player input, which is an overkill, but doesn't affects   -- screensavers, because they are UI, but not human.-  modifyClient $ \cli -> cli {sbfsD = EM.empty}+  modifyClient $ \cli -> cli {sbfsD = EM.empty, slastLost = ES.empty}   let loop :: Maybe (Bool, Overlay) -> m RequestUI       loop mover = do         (lastBlank, over) <- case mover of@@ -125,9 +126,20 @@                 {swaitTimes = if swaitTimes cli > 0                               then - swaitTimes cli                               else 0}-              if km == K.escKM && isNothing stgtMode && isJust mover-                then cmdHumanSem Clear-                else cmdHumanSem cmd+              escAI <- getsClient sescAI+              case escAI of+                EscAIStarted -> do+                  modifyClient $ \cli -> cli {sescAI = EscAIMenu}+                  cmdHumanSem cmd+                EscAIMenu -> do+                  unless (km `elem` [K.escKM, K.returnKM]) $+                    modifyClient $ \cli -> cli {sescAI = EscAIExited}+                  cmdHumanSem cmd+                _ -> do+                  modifyClient $ \cli -> cli {sescAI = EscAINothing}+                  if km == K.escKM && isNothing stgtMode && isJust mover+                  then cmdHumanSem Clear+                  else cmdHumanSem cmd             Nothing -> let msgKey = "unknown command <" <> K.showKM km <> ">"                        in fmap Left $ promptToSlideshow msgKey         -- The command was failed or successful and if the latter,@@ -170,6 +182,7 @@   let pong ats = return $ ReqUIPong ats       underAI = isAIFact fact   if escPressed && underAI && fleaderMode (gplayer fact) /= LeaderNull then do+    modifyClient $ \cli -> cli {sescAI = EscAIStarted}     -- Ask server to turn off AI for the faction's leader.     let atomicCmd = UpdAtomic $ UpdAutoFaction side False     pong [atomicCmd]

@@ -37,6 +37,7 @@   , configVi          :: !Bool  -- ^ the option for Vi keys takes precendence   , configLaptop      :: !Bool  -- ^ because the laptop keys are the default   , configFont        :: !String+  , configColorIsBold :: !Bool   , configHistoryMax  :: !Int   , configMaxFps      :: !Int   , configNoAnim      :: !Bool@@ -77,6 +78,7 @@       -- because the laptop keys are the default.       configLaptop = not configVi && getOption "movementLaptopKeys_uk8o79jl"       configFont = getOption "font"+      configColorIsBold = getOption "colorIsBold"       configHistoryMax = getOption "historyMax"       configMaxFps = max 1 $ getOption "maxFps"       configNoAnim = getOption "noAnim"@@ -111,6 +113,8 @@   let stdRuleset = Kind.stdRuleset corule   in (\dbg -> dbg {sfont =         sfont dbg `mplus` Just (configFont sconfig)}) .+     (\dbg -> dbg {scolorIsBold =+        scolorIsBold dbg `mplus` Just (configColorIsBold sconfig)}) .      (\dbg -> dbg {smaxFps =         smaxFps dbg `mplus` Just (configMaxFps sconfig)}) .      (\dbg -> dbg {snoAnim =

@@ -5,6 +5,7 @@  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 Data.Maybe@@ -25,7 +26,6 @@ import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Dice as Dice-import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemDescription@@ -37,9 +37,9 @@ import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ItemKind+import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind+import qualified Game.LambdaHack.Content.TileKind as TK  -- * RespUpdAtomicUI @@ -64,16 +64,30 @@     destroyActorUI aid body "die" "be destroyed" verbose     side <- getsClient sside     when (bfid body == side && not (bproj body)) stopPlayBack-  UpdCreateItem iid _ k c -> do-    -- TODO: probably not Nothing if container not CGround-    updateItemSlot Nothing iid-    itemVerbMU iid k (MU.Text $ "appear" <+> ppContainer c) (storeFromC c)+  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+      CEmbed{} -> return ()+      CFloor{} -> do+        updateItemSlot Nothing iid+        itemVerbMU iid kit (MU.Text $ "appear" <+> ppContainer c) c+      CTrunk{} -> return ()     stopPlayBack-  UpdDestroyItem iid _ k c -> itemVerbMU iid k "disappear" (storeFromC c)+  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 _ k c -> do+  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.@@ -81,35 +95,38 @@     case ( lookup iid $ map swap $ EM.assocs letterSlots          , lookup iid $ map swap $ IM.assocs numberSlots ) of       (Nothing, Nothing) -> do-        updateItemSlot Nothing iid         case c of-          CActor{} -> return ()  -- not actionable at this time+          CActor aid CGround -> updateItemSlotSide aid iid+          CActor{} -> return ()+          CEmbed{} -> return ()           CFloor lid p -> do+            updateItemSlot Nothing iid             scursorOld <- getsClient scursor             case scursorOld of               TEnemy{} -> return ()  -- probably too important to overwrite               TEnemyPos{} -> return ()               _ -> modifyClient $ \cli -> cli {scursor = TPoint lid p}-            itemVerbMU iid k "be spotted" CGround+            itemVerbMU iid kit "be spotted" c             stopPlayBack           CTrunk{} -> return ()       _ -> return ()  -- seen recently (still has a slot assigned)   UpdLoseItem{} -> skip   -- Move actors and items.   UpdMoveActor aid _ _ -> lookAtMove aid-  UpdWaitActor aid _ -> when verbose $ aVerbMU aid "wait"+  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   -- Change actor attributes.   UpdAgeActor{} -> skip+  UpdRefillHP _ 0 -> skip   UpdRefillHP aid n -> do     when verbose $-      aVerbMU aid $ MU.Text $ (if n > 0 then "heal" else "lose")-                              <+> tshow (abs n) <> "HP"+      aidVerbMU aid $ MU.Text $ (if n > 0 then "heal" else "lose")+                              <+> tshow (abs $ n `divUp` oneM) <> "HP"     mleader <- getsClient _sleader     when (Just aid == mleader) $ do       b <- getsState $ getActorBody aid-      hpMax <- sumOrganEqpClient Effect.EqpSlotAddMaxHP aid+      hpMax <- sumOrganEqpClient IK.EqpSlotAddMaxHP aid       when (bhp b == xM hpMax && hpMax > 0) $ do         actorVerbMU aid b "recover your health fully"         stopPlayBack@@ -122,7 +139,7 @@         allFoes  <- getsState $ actorRegularList (isAtWar fact) (blid b)         let closeFoes = filter ((<= 3) . chessDist (bpos b) . bpos) allFoes         when (null closeFoes) $ do  -- obvious where the feeling comes from-          aVerbMU aid "hear something"+          aidVerbMU aid "hear something"           msgDuplicateScrap   UpdOldFidActor{} -> skip   UpdTrajectory{} -> skip@@ -161,7 +178,9 @@         showDipl War = "at war"     msgAdd $ name1 <+> "and" <+> name2 <+> "are now" <+> showDipl toDipl <> "."   UpdTacticFaction{} -> skip-  UpdAutoFaction{} -> skip+  UpdAutoFaction fid b -> do+    side <- getsClient sside+    when (fid == side) $ setFrontAutoYes b   UpdRecordKill{} -> skip   -- Alter map.   UpdAlterTile{} -> when verbose $ return ()  -- TODO: door opens@@ -176,13 +195,13 @@     let t = lvl `at` p         verb | t == toTile = "confirm"              | otherwise = "reveal"-        subject2 = MU.Text $ tname $ okind fromTile+        subject2 = MU.Text $ TK.tname $ okind fromTile         verb2 = "be"     let msg = makeSentence [ MU.SubjectVerbSg subject verb                            , "that the"                            , MU.SubjectVerbSg subject2 verb2                            , "a hidden"-                           , MU.Text $ tname $ okind toTile ]+                           , MU.Text $ TK.tname $ okind toTile ]     msgAdd msg   UpdLearnSecrets{} -> skip   UpdSpotTile{} -> skip@@ -191,29 +210,42 @@   UpdSpotSmell{} -> skip   UpdLoseSmell{} -> skip   -- Assorted.-  UpdAgeGame {} -> skip-  UpdDiscover _ _ iid _ _ -> discover oldStateClient iid-  UpdCover{} ->  skip  -- don't spam when doing undo-  UpdDiscoverKind _ _ iid _ -> discover oldStateClient iid-  UpdCoverKind{} ->  skip  -- don't spam when doing undo-  UpdDiscoverSeed _ _ iid _ -> discover oldStateClient iid+  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 _ _ _ _ _ _ -> do+  UpdRestart fid _ _ _ _ _ -> do     mode <- getModeClient     msgAdd $ "New game started in" <+> mname mode <+> "mode." <+> mdesc mode     -- TODO: use a vertical animation instead, e.g., roll down,     -- and reveal the first frame of a new game, not blank screen.     history <- getsClient shistory     when (lengthHistory history > 1) $ fadeOutOrIn False+    fact <- getsState $ (EM.! fid) . sfactionD+    setFrontAutoYes $ isAIFact fact   UpdRestartServer{} -> skip-  UpdResume{} -> skip+  UpdResume fid _ -> do+    fact <- getsState $ (EM.! fid) . sfactionD+    setFrontAutoYes $ isAIFact fact   UpdResumeServer{} -> skip   UpdKillExit{} -> skip   UpdWriteSave -> when verbose $ msgAdd "Saving backup."   UpdMsgAll msg -> msgAdd msg   UpdRecordHistory _ -> recordHistory +updateItemSlotSide :: MonadClient m => ActorId -> ItemId -> m ()+updateItemSlotSide aid iid = do+  side <- getsClient sside+  b <- getsState $ getActorBody aid+  if bfid b == side+  then updateItemSlot (Just aid) iid+  else updateItemSlot Nothing iid+ lookAtMove :: MonadClientUI m => ActorId -> m () lookAtMove aid = do   body <- getsState $ getActorBody aid@@ -225,7 +257,7 @@     lookMsg <- lookAt False "" True (bpos body) aid ""     msgAdd lookMsg   fact <- getsState $ (EM.! bfid body) . sfactionD-  if side == bfid body then do+  if not (bproj body) && side == bfid body then do     foes <- getsState $ actorList (isAtWar fact) (blid body)     when (any (adjacent (bpos body) . bpos) foes) stopPlayBack   else when (isAtWar fact side) $ do@@ -238,28 +270,59 @@   subject <- partActorLeader aid b   msgAdd $ makeSentence [MU.SubjectVerbSg subject verb] -aVerbMU :: MonadClientUI m => ActorId -> MU.Part -> m ()-aVerbMU aid verb = do+aidVerbMU :: MonadClientUI m => ActorId -> MU.Part -> m ()+aidVerbMU aid verb = do   b <- getsState $ getActorBody aid   actorVerbMU aid b verb  itemVerbMU :: MonadClientUI m-           => ItemId -> Int -> MU.Part -> CStore -> m ()-itemVerbMU iid k verb cstore = assert (k > 0) $ do+           => ItemId -> ItemQuant -> MU.Part -> Container -> m ()+itemVerbMU iid kit@(k, _) verb c = assert (k > 0) $ do+  lid <- getsState $ lidFromC c+  localTime <- getsState $ getLocalTime lid   itemToF <- itemToFullClient-  let subject = partItemWs k cstore (itemToF iid k)+  let subject = partItemWs k 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 -aiVerbMU :: MonadClientUI m-         => ActorId -> MU.Part -> ItemId -> Int -> CStore -> m ()-aiVerbMU aid verb iid k cstore = do-  itemToF <- itemToFullClient-  subject <- partAidLeader aid-  let msg = makeSentence [ MU.SubjectVerbSg subject verb-                         , partItemWs k cstore (itemToF iid k) ]-  msgAdd msg+-- TODO: split into 3 parts wrt ek and reuse somehow, e.g., the secret part+-- We assume the item is inside the specified container.+-- So, this function can't be used for, e.g., @UpdDestroyItem@.+itemAidVerbMU :: MonadClientUI m+              => ActorId -> MU.Part+              -> ItemId -> Either (Maybe Int) Int -> CStore+              -> m ()+itemAidVerbMU aid verb iid ek cstore = do+  let c = CActor aid cstore+  bag <- getsState $ getCBag c+  -- 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+      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+            Left Nothing ->+              let (name, stats) = partItem c 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+                    name = MU.Phrase [secretName, secretAE]+                    nameList = if n == 1+                               then ["the", name]+                               else ["the", MU.Text $ tshow n, MU.Ws name]+                in MU.Phrase nameList+          msg = makeSentence [MU.SubjectVerbSg subject verb, object]+      msgAdd msg  msgDuplicateScrap :: MonadClientUI m => m () msgDuplicateScrap = do@@ -273,10 +336,17 @@     modifyClient $ \cli -> cli {sreport = repRest}  -- TODO: "XXX spots YYY"? or blink or show the changed cursor?-createActorUI :: MonadClientUI m => ActorId -> Actor -> Bool -> MU.Part -> m ()+createActorUI :: MonadClientUI m+              => ActorId -> Actor -> Bool -> MU.Part -> m () createActorUI aid body verbose verb = do   side <- getsClient sside-  when (bfid body /= side && not (bproj body) || verbose) $+  -- 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@@ -288,7 +358,7 @@       -- into account.       modifyClient $ \cli -> cli {scursor = TEnemy aid False}     stopPlayBack-  when (bfid body == side && not (bproj body)) $ lookAtMove aid+  lookAtMove aid  destroyActorUI :: MonadClientUI m                => ActorId -> Actor -> MU.Part -> MU.Part -> Bool -> m ()@@ -298,40 +368,36 @@     actorVerbMU aid body verb     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 c1 c2 = do-  side <- getsClient sside+moveItemUI verbose iid k aid cstore1 cstore2 = do+  let verb = verbCStore cstore2+  when (cstore2 == CGround) $ updateItemSlotSide aid iid   b <- getsState $ getActorBody aid-  case (c1, c2) of-    (_, _) | c1 == CGround -> do-      when (bfid b == side) $ updateItemSlot (Just aid) iid-      fact <- getsState $ (EM.! bfid b) . sfactionD-      let underAI = isAIFact fact-      mleader <- getsClient _sleader-      if Just aid == mleader && not underAI then do-        itemToF <- itemToFullClient-        (letterSlots, _) <- getsClient sslots-        bag <- getsState $ getCBag $ CActor aid c2-        let n = bag EM.! iid-        case lookup iid $ map swap $ EM.assocs letterSlots of-          Just l -> msgAdd $ makePhrase-                      [ "\n"-                      , slotLabel $ Left l-                      , "-"-                      , partItemWs n c2 (itemToF iid n)-                      , "\n" ]-          Nothing -> return ()-      else when (c1 == CGround && c1 /= c2) $-        aiVerbMU aid "get" iid k c2-    (_, CGround) | c1 /= c2 -> do-      when verbose $ aiVerbMU aid "drop" iid k c1-      if bfid b == side-        then updateItemSlot (Just aid) iid-        else updateItemSlot Nothing iid-    _ -> return ()+  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  displaceActorUI :: MonadClientUI m => ActorId -> ActorId -> m () displaceActorUI source target = do@@ -394,61 +460,70 @@       msgAdd msg   case (toSt, partingPart) of     (Just status, Just pp) -> do-      (bag, total) <- case mbody of-        Just body | fid == side -> getsState $ calculateTotal body+      startingSlide <- promptToSlideshow moreMsg+      recordHistory  -- we are going to exit or restart, so record+      let bodyToItemSlides b = do+            (bag, tot) <- getsState $ calculateTotal b+            let currencyName = MU.Text $ IK.iname $ okind+                               $ ouniqGroup "currency"+                itemMsg = makeSentence [ "Your loot is worth"+                                       , MU.CarWs tot currencyName ]+                          <+> 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+              sli <- overlayToSlideshow itemMsg io+              return (sli, tot)+      (itemSlides, total) <- case mbody of+        Just b | fid == side -> bodyToItemSlides b         _ -> case gleader fact of-          Nothing -> return (EM.empty, 0)+          Nothing -> return (mempty, 0)           Just (aid, _) -> do             b <- getsState $ getActorBody aid-            getsState $ calculateTotal b-      let currencyName = MU.Text $ iname $ okind $ ouniqGroup "currency"-          itemMsg = makeSentence [ "Your loot is worth"-                                 , MU.CarWs total currencyName ]-                    <+> moreMsg-      startingSlide <- promptToSlideshow moreMsg-      recordHistory  -- we are going to exit or restart, so record-      itemSlides <--        if EM.null bag then return mempty-        else do-          io <- itemOverlay CGround bag-          overlayToSlideshow itemMsg io-      -- Show score for any UI client, even though it is saved only-      -- for human UI clients.+            bodyToItemSlides b+      -- Show score for any UI client (except after ESC),+      -- even though it is saved only for human UI clients.       scoreSlides <- scoreToSlideshow total status       partingSlide <- promptToSlideshow $ pp <+> moreMsg       shutdownSlide <- promptToSlideshow pp-      -- TODO: First ESC cancels items display.-      void $ getInitConfirms ColorFull []-           $ startingSlide <> itemSlides-      -- TODO: Second ESC cancels high score and parting message display.-      -- The last slide stays onscreen during shutdown, etc.-             <> scoreSlides <> partingSlide <> shutdownSlide+      escAI <- getsClient sescAI+      unless (escAI == EscAIExited) $+        -- TODO: First ESC cancels items display.+        void $ getInitConfirms ColorFull []+             $ startingSlide <> itemSlides+        -- TODO: Second ESC cancels high score and parting message display.+        -- The last slide stays onscreen during shutdown, etc.+               <> scoreSlides <> partingSlide <> shutdownSlide       -- TODO: perhaps use a vertical animation instead, e.g., roll down       -- and put it before item and score screens (on blank background)       unless (fmap stOutcome toSt == Just Camping) $ fadeOutOrIn True     _ -> return () -discover :: MonadClientUI m => StateClient -> ItemId ->  m ()-discover oldcli iid = do+discover :: MonadClientUI m+         => LevelId -> Point -> StateClient -> ItemId -> m ()+discover lid p oldcli iid = do   cops <- getsState scops+  localTime <- getsState $ getLocalTime lid   itemToF <- itemToFullClient-  let itemFull = itemToF iid 1-      (knownName, knownAEText) = partItem CGround itemFull+  let itemFull = itemToF iid (1, [])+      c = CFloor lid p+      (knownName, knownAEText) = partItem c 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 CGround itemSecret+      (secretName, secretAEText) = partItem c lid localTime itemSecret       msg = makeSentence         [ "the", MU.SubjectVerbSg (MU.Phrase [secretName, secretAEText])                                   "turn out to be"         , MU.AW $ MU.Phrase [knownName, knownAEText] ]       oldItemFull =         itemToFull cops (sdiscoKind oldcli) (sdiscoEffect oldcli)-                   iid (itemBase itemFull) 1+                   iid (itemBase itemFull) (1, [])   -- Compare descriptions of all aspects and effects to determine   -- if the discovery was meaningful to the player.-  when (textAllAE False CEqp itemFull /= textAllAE False CEqp oldItemFull) $+  when (textAllAE False c itemFull /= textAllAE False c oldItemFull) $     msgAdd msg  -- * RespSfxAtomicUI@@ -461,14 +536,18 @@     spart <- partAidLeader source     tpart <- partAidLeader target     msgAdd $ makeSentence [MU.SubjectVerbSg spart "shrink away from", tpart]-  SfxProject aid iid -> aiVerbMU aid "aim" iid 1 CInv-  SfxCatch aid iid -> aiVerbMU aid "catch" iid 1 CInv-  SfxActivate aid iid k -> aiVerbMU aid "activate" iid k CInv-  SfxCheck aid iid k -> aiVerbMU aid "deactivate" iid k CInv+  SfxProject 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+  SfxCheck aid iid cstore ->+    itemAidVerbMU aid "deactivate" iid (Left $ Just 1) cstore   SfxTrigger aid _p _feat ->-    when verbose $ aVerbMU aid "trigger"  -- TODO: opens door, etc.+    when verbose $ aidVerbMU aid "trigger"  -- TODO: opens door, etc.   SfxShun aid _p _ ->-    when verbose $ aVerbMU aid "shun"  -- TODO: shuns stairs down+    when verbose $ aidVerbMU aid "shun"  -- TODO: shuns stairs down   SfxEffect fidSource aid effect -> do     b <- getsState $ getActorBody aid     side <- getsClient sside@@ -489,9 +568,10 @@                                    || bhp b < p)           (deadBefore, verbDie) =             case effect of-              Effect.Hurt p | deadPreviousTurn (xM $ Dice.maxDice p) ->+              IK.Hurt p | deadPreviousTurn (xM $ Dice.maxDice p) ->                 (True, hurtExtra)-              Effect.RefillHP p | deadPreviousTurn (xM 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@@ -502,17 +582,25 @@                    else animate (blid b) $ deathBody $ bpos b         displayActorStart b animDie     else case effect of-        Effect.NoEffect t -> msgAdd $ "Nothing happens." <+> t-        Effect.RefillHP p | p == 1 -> skip  -- no spam from regen items-        Effect.RefillHP p | p > 0 -> do+        IK.NoEffect t -> msgAdd $ "Nothing happens." <+> t+        IK.Hurt{} -> skip  -- avoid spam; SfxStrike just sent+        IK.Burn{} ->           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+        IK.RefillHP p | p > 0 -> do+          if fid == side then             actorVerbMU aid b "feel healthier"           else             actorVerbMU aid b "look healthier"           let ps = (bpos b, bpos b)           animFrs <- animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue           displayActorStart b animFrs-        Effect.RefillHP _ -> do+        IK.RefillHP p | p == -1 -> skip  -- no spam from poison+        IK.RefillHP _ -> do           if fid == side then             actorVerbMU aid b "feel wounded"           else@@ -520,17 +608,32 @@           let ps = (bpos b, bpos b)           animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red           displayActorStart b animFrs-        Effect.Hurt{} -> skip  -- avoid spam; SfxStrike just sent-        Effect.RefillCalm p | p == 1 -> skip  -- no spam from regen items-        Effect.RefillCalm p | p > 0 -> do+        IK.OverfillHP p | p > 0 -> do           if fid == side then+            actorVerbMU aid b "feel healthier"+          else+            actorVerbMU aid b "look healthier"+          let ps = (bpos b, bpos b)+          animFrs <- animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue+          displayActorStart b animFrs+        IK.OverfillHP _ -> do+          if fid == side then+            actorVerbMU aid b "feel wounded"+          else+            actorVerbMU aid b "look wounded"+          let ps = (bpos b, bpos b)+          animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red+          displayActorStart b animFrs+        IK.RefillCalm p | p == 1 -> skip  -- no spam from regen items+        IK.RefillCalm p | p > 0 -> do+          if fid == side then             actorVerbMU aid b "feel calmer"           else             actorVerbMU aid b "look calmer"           let ps = (bpos b, bpos b)           animFrs <- animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue           displayActorStart b animFrs-        Effect.RefillCalm _ -> do+        IK.RefillCalm _ -> do           if fid == side then             actorVerbMU aid b "feel agitated"           else@@ -538,16 +641,32 @@           let ps = (bpos b, bpos b)           animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red           displayActorStart b animFrs-        Effect.Dominate -> do+        IK.OverfillCalm p | p > 0 -> do+          if fid == side then+            actorVerbMU aid b "feel calmer"+          else+            actorVerbMU aid b "look calmer"+          let ps = (bpos b, bpos b)+          animFrs <- animate (blid b) $ twirlSplash ps Color.BrBlue Color.Blue+          displayActorStart b animFrs+        IK.OverfillCalm _ -> do+          if fid == side then+            actorVerbMU aid b "feel agitated"+          else+            actorVerbMU aid b "look agitated"+          let ps = (bpos b, bpos b)+          animFrs <- animate (blid b) $ twirlSplash ps Color.BrRed Color.Red+          displayActorStart b animFrs+        IK.Dominate -> do           -- For subsequent messages use the proper name, never "you".           let subject = partActor b           if fid /= fidSource then do  -- before domination             if bcalm b == 0 then do -- sometimes only a coincidence, but nm-              aVerbMU aid $ MU.Text "yield, under extreme pressure"+              aidVerbMU aid $ MU.Text "yield, under extreme pressure"             else if fid == side then-              aVerbMU aid $ MU.Text "black out, dominated by foes"+              aidVerbMU aid $ MU.Text "black out, dominated by foes"             else-              aVerbMU aid $ MU.Text "decide abrubtly to switch allegiance"+              aidVerbMU aid $ MU.Text "decide abrubtly to switch allegiance"             fidName <- getsState $ gname . (EM.! fid) . sfactionD             let verb = "be no longer controlled by"             msgAdd $ makeSentence@@ -558,68 +677,63 @@             let verb = "be now under"             msgAdd $ makeSentence               [MU.SubjectVerbSg subject verb, MU.Text fidSourceName, "control"]-        Effect.Impress{} ->+        IK.Impress{} ->           actorVerbMU aid b           $ if boldfid b /= bfid b             then-              "get sobered and refocused by the fragrant moisture"+              "get refocused by the fragrant moisture"             else               "inhale the sweet smell that weakens resolve and erodes loyalty"-        Effect.CallFriend{} -> skip-        Effect.Summon{} -> skip-        Effect.CreateItem{} -> skip-        Effect.ApplyPerfume ->-          msgAdd "The fragrance quells all scents in the vicinity."-        Effect.Burn{} ->-          if fid == side then-            actorVerbMU aid b "feel burned"-          else-            actorVerbMU aid b "look burned"-        Effect.Ascend k | k > 0 -> actorVerbMU aid b "find a way upstairs"-        Effect.Ascend k | k < 0 -> actorVerbMU aid b "find a way downstairs"-        Effect.Ascend{} -> assert `failure` sfx-        Effect.Escape{} -> skip-        Effect.Paralyze{} -> actorVerbMU aid b "be paralyzed"-        Effect.InsertMove{} -> actorVerbMU aid b "move with extreme speed"-        Effect.DropBestWeapon -> actorVerbMU aid b "be disarmed"-        Effect.DropEqp _ False -> actorVerbMU aid b "be stripped"  -- TODO-        Effect.DropEqp _ True -> actorVerbMU aid b "be violently stripped"-        Effect.SendFlying{} -> actorVerbMU aid b "be sent flying"-        Effect.PushActor{} -> actorVerbMU aid b "be pushed"-        Effect.PullActor{} -> actorVerbMU aid b "be pulled"-        Effect.Teleport t | t > 9 -> actorVerbMU aid b "teleport"-        Effect.Teleport{} -> actorVerbMU aid b "blink"-        Effect.PolyItem cstore -> do+        IK.CallFriend{} -> skip+        IK.Summon{} -> skip+        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.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.DropItem _ _ False -> actorVerbMU aid b "be stripped"  -- TODO+        IK.DropItem _ _ True -> actorVerbMU aid b "be violently stripped"+        IK.PolyItem cstore -> do+          localTime <- getsState $ getLocalTime $ blid b           allAssocs <- fullAssocsClient aid [cstore]           case allAssocs of             [] -> return ()  -- invisible items?             (_, ItemFull{..}) : _ -> do               let itemSecret = itemNoDisco (itemBase, itemK)-                  (secretName, secretAEText) = partItem cstore itemSecret+                  (secretName, secretAEText) = partItem (CActor aid cstore) (blid b) localTime itemSecret                   subject = partActor b                   verb = "repurpose"                   store = MU.Text $ ppCStore cstore               msgAdd $ makeSentence                 [ MU.SubjectVerbSg subject verb                 , "the", secretName, secretAEText, store ]-        Effect.Identify cstore -> do+        IK.Identify cstore -> do  -- here cstore is the real location           allAssocs <- fullAssocsClient aid [cstore]           case allAssocs of             [] -> return ()  -- invisible items?             (_, ItemFull{..}) : _ -> do-              let itemSecret = itemNoDisco (itemBase, itemK)-                  (secretName, secretAEText) = partItem cstore itemSecret-                  subject = partActor b-                  verb = "compare"+              let subject = partActor b+                  verb = "inspect"                   store = MU.Text $ ppCStore cstore               msgAdd $ makeSentence                 [ MU.SubjectVerbSg subject verb-                , "old notes with the", secretName, secretAEText, store ]-        Effect.ActivateInv{} -> skip-        Effect.Explode{} -> skip  -- lots of visual feedback-        Effect.OneOf{} -> skip-        Effect.OnSmash{} -> assert `failure` sfx-        Effect.TimedAspect{} -> skip  -- TODO+                , "an item", store ]+        IK.SendFlying{} -> actorVerbMU aid b "be sent flying"+        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.ApplyPerfume ->+          msgAdd "The fragrance quells all scents in the vicinity."+        IK.OneOf{} -> skip+        IK.OnSmash{} -> assert `failure` sfx+        IK.Recharging{} -> assert `failure` sfx+        IK.Temporary t -> actorVerbMU aid b $ MU.Text t   SfxMsgFid _ msg -> msgAdd msg   SfxMsgAll msg -> msgAdd msg   SfxActorStart aid -> do@@ -666,14 +780,19 @@   spart <- partActorLeader source sb   tpart <- partActorLeader target tb   spronoun <- partPronounLeader source sb-  let itemFull = itemToF iid 1+  localTime <- getsState $ getLocalTime (blid sb)+  -- We don't show the charging status in the weapon strike message. Succinct.+  let itemFull = itemToF iid (1, [])       verb = case itemDisco itemFull of         Nothing -> "hit"  -- not identified-        Just ItemDisco{itemKind} -> iverbHit itemKind+        Just ItemDisco{itemKind} -> IK.iverbHit itemKind       isOrgan = iid `EM.member` borgan sb-      partItemChoice = if isOrgan-                       then partItemWownW spronoun COrgan-                       else partItemAW CEqp+      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       msg HitClear = makeSentence $         [MU.SubjectVerbSg spart verb, tpart]         ++ if bproj sb@@ -685,7 +804,7 @@               then [ MU.SubjectVerbSg spart "connect" ]               else [ MU.SubjectVerbSg spart "swing"                    , partItemChoice itemFull ]-        in makeSentence [ MU.Phrase sActs MU.:> ", but"+        in makeSentence [ MU.Phrase sActs <> ", but"                         , MU.SubjectVerbSg tpart "block"                         , if n > 1 then "doggedly" else "partly"                         ]

@@ -23,7 +23,6 @@ import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color import qualified Game.LambdaHack.Common.Dice as Dice-import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemDescription@@ -40,9 +39,9 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind+import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind+import qualified Game.LambdaHack.Content.TileKind as TK  -- | Color mode for the display. data ColorMode =@@ -95,7 +94,7 @@       dis pos0 =         let tile = lvl `at` pos0             tk = tokind tile-            floorBag = lvl `atI` pos0+            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@@ -116,8 +115,8 @@             -- over both visible and invisible tiles.             vcolor               | smarkSuspect && Tile.isSuspect cotile tile = Color.BrCyan-              | vis = tcolor tk-              | otherwise = tcolor2 tk+              | vis = TK.tcolor tk+              | otherwise = TK.tcolor2 tk             fgOnPathOrLine = case (vis, Tile.isWalkable cotile tile) of               _ | tile == unknownId -> Color.BrBlack               _ | Tile.isSuspect cotile tile -> Color.BrCyan@@ -141,7 +140,7 @@                   (timeDeltaToDigit smellTimeout smlt, rainbow pos0)                   | otherwise ->                   case floorIids of-                    [] -> (tsymbol tk, Color.defAttr {Color.fg = vcolor})+                    [] -> (TK.tsymbol tk, Color.defAttr {Color.fg = vcolor})                     iid : _ -> viewItem $ getItemBody iid s             vis = ES.member pos0 $ totalVisible per             a = case dm of@@ -255,8 +254,8 @@       let (darkL, bracedL, hpDelta, calmDelta,            ahpS, bhpS, acalmS, bcalmS) =             let b@Actor{bhp, bcalm} = getActorBody leader s-                amaxHP = sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems-                amaxCalm = sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems+                amaxHP = sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems+                amaxCalm = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems             in ( not (actorInAmbient b s)                , braced b, bhpDelta b, bcalmDelta b                , tshow $ max 0 amaxHP, tshow (bhp `divUp` oneM)@@ -295,22 +294,21 @@     Just leader -> do       allAssocs <- fullAssocsClient leader [CEqp, COrgan]       let activeItems = map snd allAssocs-          damage = case strongestSlotNoFilter Effect.EqpSlotWeapon allAssocs of+          damage = case strongestSlotNoFilter IK.EqpSlotWeapon allAssocs of             (_, (_, itemFull)) : _->-              let getD :: Effect.Effect a -> Maybe Dice.Dice-                       -> Maybe Dice.Dice-                  getD (Effect.Hurt dice) _ = Just dice+              let getD :: IK.Effect -> Maybe Dice.Dice -> Maybe Dice.Dice+                  getD (IK.Hurt dice) _ = Just dice                   getD _ acc = acc                   mdice = case itemDisco itemFull of                     Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->                       foldr getD Nothing jeffects                     Just ItemDisco{itemKind} ->-                      foldr getD Nothing (ieffects itemKind)+                      foldr getD Nothing (IK.ieffects itemKind)                     Nothing -> Nothing                   tdice = case mdice of                     Nothing -> "0"                     Just dice -> tshow dice-                  bonus = sumSlotNoFilter Effect.EqpSlotAddHurtMelee activeItems+                  bonus = sumSlotNoFilter IK.EqpSlotAddHurtMelee activeItems                   unknownBonus = unknownMelee activeItems                   tbonus = if bonus == 0                            then if unknownBonus then "+?" else ""

@@ -32,6 +32,8 @@       -- ^ flush frames, possibly show fadeout/fadein and ask for a keypress   | FrontSlides {frontClear :: ![K.KM], frontSlides :: ![SingleFrame]}       -- ^ show a whole slideshow without interleaving with other clients+  | FrontAutoYes !Bool+      -- ^ set the frontend option for auto-answering prompts   | FrontFinish       -- ^ exit frontend loop @@ -65,12 +67,11 @@     then return km     else promptGetKey fs keys frame -getConfirmGeneric :: RawFrontend -> [K.KM] -> SingleFrame -> IO (Maybe Bool)-getConfirmGeneric fs clearKeys frame = do-  let DebugModeCli{snoMore} = fdebugCli fs-  -- TODO: turn noMore off somehow when faction not under computer control;-  -- perhaps by adding a FrontReq request that turns it off/on?-  if snoMore then do+getConfirmGeneric :: Bool -> RawFrontend -> [K.KM] -> SingleFrame+                  -> IO (Maybe Bool)+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   else do@@ -84,33 +85,33 @@  -- Read UI requests from the client and send them to the frontend, loopFrontend :: RawFrontend -> ChanFrontend -> IO ()-loopFrontend fs ChanFrontend{..} = loop+loopFrontend fs ChanFrontend{..} = loop False  where   writeKM :: K.KM -> IO ()   writeKM km = STM.atomically $ STM.writeTQueue responseF km -  loop :: IO ()-  loop = do+  loop :: Bool -> IO ()+  loop autoYes = do     efr <- STM.atomically $ STM.readTQueue requestF     case efr of       FrontNormalFrame{..} -> do         fdisplay fs False (Just frontFrame)-        loop+        loop autoYes       FrontRunningFrame{..} -> do         fdisplay fs True (Just frontFrame)-        loop+        loop autoYes       FrontDelay -> do         fdisplay fs False Nothing-        loop+        loop autoYes       FrontKey{..} -> do         km <- promptGetKey fs frontKM frontFr         writeKM km-        loop+        loop autoYes       FrontSlides{frontSlides = []} -> do         -- Hack.         fsyncFrames fs         writeKM K.spaceKM-        loop+        loop autoYes       FrontSlides{..} -> do         let displayFrs frs srf =               case frs of@@ -119,7 +120,7 @@                   fdisplay fs False (Just x)                   writeKM K.spaceKM                 x : xs -> do-                  go <- getConfirmGeneric fs frontClear x+                  go <- getConfirmGeneric autoYes fs frontClear x                   case go of                     Nothing -> writeKM K.escKM                     Just True -> displayFrs xs (x : srf)@@ -127,7 +128,9 @@                       [] -> displayFrs frs srf                       y : ys -> displayFrs (y : frs) ys         displayFrs frontSlides []-        loop+        loop autoYes+      FrontAutoYes b ->+        loop b       FrontFinish ->         return ()         -- Do not loop again.

@@ -121,6 +121,7 @@     C.KeyBeg         -> (K.Begin,   K.NoModifier)     C.KeyB2          -> (K.Begin,   K.NoModifier)     C.KeyClear       -> (K.Begin,   K.NoModifier)+    C.KeyIC          -> (K.Insert,  K.NoModifier)     -- No KP_ keys; see <https://github.com/skogsbaer/hscurses/issues/10>     -- TODO: try to get the Control modifier for keypad keys from the escape     -- gibberish and use Control-keypad for KP_ movement.

@@ -10,8 +10,10 @@   , frontendName, startup   ) where +import Control.Applicative import Control.Concurrent 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@@ -43,7 +45,7 @@ data FrontendSession = FrontendSession   { sview       :: !TextView                    -- ^ the widget to draw to   , stags       :: !(M.Map Color.Attr TextTag)  -- ^ text color tags for fg/bg-  , schanKey    :: !(Chan K.KM)                 -- ^ channel for keyboard input+  , schanKey    :: !(STM.TQueue K.KM)           -- ^ channel for keyboard input   , sframeState :: !(MVar FrameState)       -- ^ State of the frame finite machine. This mvar is locked       -- for a short time only, because it's needed, among others,@@ -103,7 +105,7 @@              mapM (\ ak -> do                       tt <- textTagNew Nothing                       textTagTableAdd ttt tt-                      doAttr tt ak+                      doAttr sdebugCli tt ak                       return (ak, tt))                [ Color.Attr{fg, bg}                | fg <- [minBound..maxBound], bg <- Color.legalBG ]@@ -114,7 +116,7 @@   textViewSetEditable sview False   textViewSetCursorVisible sview False   -- Set up the channel for keyboard input.-  schanKey <- newChan+  schanKey <- STM.atomically $ STM.newTQueue   -- Set up the frame state.   let frameState = FNone   -- Create the session record.@@ -139,13 +141,17 @@     let !key = K.keyTranslate n #endif         !modifier = modifierTranslate mods+        readAll = do+          res <- STM.atomically $ STM.tryReadTQueue schanKey+          when (isJust res) $ readAll     liftIO $ do       unless (deadKey n) $ do-        -- If ESC, also mark it specially.-        when (key == K.Esc) $+        -- If ESC, also mark it specially and reset the key channel.+        when (key == K.Esc) $ do           void $ tryPutMVar escMVar ()+          readAll         -- Store the key in the channel.-        writeChan schanKey K.KM{key, modifier}+        STM.atomically $ STM.writeTQueue schanKey K.KM{key, modifier}       return True   -- Set the font specified in config, if any.   f <- fontDescriptionFromString $ fromMaybe "" sfont@@ -157,7 +163,7 @@     liftIO $ case but of       RightButton -> do         fsd <- fontSelectionDialogNew ("Choose font" :: String)-        cf  <- readIORef currentfont  -- TODO: "Terminus,Monospace" fails+        cf  <- readIORef currentfont         fds <- fontDescriptionToString cf         fontSelectionDialogSetFontName fsd (fds :: String)         fontSelectionDialogSetPreviewText fsd ("eee...@.##+##" :: String)@@ -388,9 +394,14 @@  -- Display all queued frames, synchronously. displayAllFramesSync :: FrontendSession -> FrameState -> IO ()-displayAllFramesSync sess@FrontendSession{sdebugCli=DebugModeCli{..}} fs = do+displayAllFramesSync sess@FrontendSession{sdebugCli=DebugModeCli{..}, sescMVar}+                     fs = do+  escPressed <- case sescMVar of+    Nothing -> return False+    Just escMVar -> not <$> isEmptyMVar escMVar   let maxFps = fromMaybe defaultMaxFps smaxFps   case fs of+    _ | escPressed -> return ()     FPushed{..} ->       case tryReadLQueue fpushed of         Just (Just frame, queue) -> do@@ -423,7 +434,7 @@ fpromptGetKey sess@FrontendSession{..}               frame = do   pushFrame sess True True $ Just frame-  km <- readChan schanKey+  km <- STM.atomically $ STM.readTQueue schanKey   case km of     K.KM{key=K.Space} ->       -- Drop frames up to the first empty frame.@@ -462,10 +473,21 @@ modifierTranslate mods =   if Control `elem` mods then K.Control else K.NoModifier -doAttr :: TextTag -> Color.Attr -> IO ()-doAttr tt attr@Color.Attr{fg, bg}+doAttr :: DebugModeCli -> TextTag -> Color.Attr -> IO ()+doAttr sdebugCli tt attr@Color.Attr{fg, bg}   | attr == Color.defAttr = return ()-  | fg == Color.defFG = set tt [textTagBackground := Color.colorToRGB bg]-  | bg == Color.defBG = set tt [textTagForeground := Color.colorToRGB fg]-  | otherwise         = set tt [textTagForeground := Color.colorToRGB fg,-                                textTagBackground := Color.colorToRGB bg]+  | 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+--     , textTagStretch := StretchUltraExpanded+       ]+  else []

@@ -11,8 +11,12 @@ import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as Ex hiding (handle)+import Data.Default 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@@ -23,6 +27,7 @@ -- | Session data maintained by the frontend. data FrontendSession = FrontendSession   { svty      :: !Vty  -- internal vty session+  , schanKey  :: !(STM.TQueue K.KM)  -- ^ channel for keyboard input   , sescMVar  :: !(Maybe (MVar ()))   , sdebugCli :: !DebugModeCli  -- ^ client configuration       -- ^ Configuration of the frontend session.@@ -35,13 +40,36 @@ -- | Starts the main program loop using the frontend input and output. startup :: DebugModeCli -> (FrontendSession -> IO ()) -> IO () startup sdebugCli k = do-  svty <- mkVty-  -- TODO: implement sescMVar, when we switch to a new vty that has-  -- a separate key listener thread or something. Avoid polling.-  a <- async $ k FrontendSession{sescMVar = Nothing, ..}-               `Ex.finally` Vty.shutdown svty+  svty <- mkVty def+  schanKey <- STM.atomically $ STM.newTQueue+  escMVar <- newEmptyMVar+  let sess = FrontendSession{sescMVar = Just escMVar, ..}+  void $ async $ storeKeys sess+  a <- async $ k sess `Ex.finally` Vty.shutdown svty   wait a +storeKeys :: FrontendSession -> IO ()+storeKeys sess@FrontendSession{..} = do+  e <- nextEvent svty  -- blocks here, so no polling+  case e of+    EvKey n mods -> do+      let !key = keyTranslate n+          !modifier = modifierTranslate mods+          readAll = do+            res <- STM.atomically $ STM.tryReadTQueue schanKey+            when (isJust res) $ readAll+      -- If ESC, also mark it specially and reset the key channel.+      case sescMVar of+        Just escMVar -> do+          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}+    _ -> return ()+  storeKeys sess+ -- | Output to the screen via the frontend. fdisplay :: FrontendSession    -- ^ frontend session data          -> Bool@@ -50,24 +78,32 @@ fdisplay _ _ Nothing = return () fdisplay FrontendSession{svty} _ (Just rawSF) =   let SingleFrame{sfLevel} = overlayOverlay rawSF-      img = (foldr (<->) empty_image-             . map (foldr (<|>) empty_image+      img = (foldr (<->) emptyImage+             . map (foldr (<|>) emptyImage                       . map (\ Color.AttrChar{..} ->                                 char (setAttr acAttr) acChar)))             $ map decodeLine sfLevel-      pic = pic_for_image img+      pic = picForImage img   in update svty pic  -- | Input key via the frontend.-nextEvent :: FrontendSession -> IO K.KM-nextEvent sess@FrontendSession{svty} = do-  e <- next_event svty-  case e of-    EvKey n mods -> do-      let key = keyTranslate n-          modifier = modifierTranslate mods-      return $! K.KM {key, modifier}-    _ -> nextEvent sess+nextKeyEvent :: FrontendSession -> IO K.KM+nextKeyEvent FrontendSession{..} = do+  km <- STM.atomically $ STM.readTQueue schanKey+  case km of+    K.KM{key=K.Space} ->+      -- Drop frames up to the first empty frame.+      -- Keep the last non-empty frame, if any.+      -- Pressing SPACE repeatedly can be used to step+      -- through intermediate stages of an animation,+      -- whereas any other key skips the whole animation outright.+--      onQueue dropStartLQueue sess+      return ()+    _ ->+      -- Show the last non-empty frame and empty the queue.+--      trimFrameState sess+      return ()+  return km  fsyncFrames :: FrontendSession -> IO () fsyncFrames _ = return ()@@ -76,7 +112,7 @@ fpromptGetKey :: FrontendSession -> SingleFrame -> IO K.KM fpromptGetKey sess frame = do   fdisplay sess True $ Just frame-  nextEvent sess+  nextKeyEvent sess  -- TODO: Ctrl-Home and Ctrl-End are the same as Home and End on some terminals -- so we should probably go back to using 0-9 (and Shift) for movement@@ -86,8 +122,8 @@   case n of     KEsc          -> K.Esc     KEnter        -> K.Return-    (KASCII ' ')  -> K.Space-    (KASCII '\t') -> K.Tab+    (KChar ' ')   -> K.Space+    (KChar '\t')  -> K.Tab     KBackTab      -> K.BackTab     KBS           -> K.BackSpace     KUp           -> K.Up@@ -99,8 +135,9 @@     KPageUp       -> K.PgUp     KPageDown     -> K.PgDn     KBegin        -> K.Begin-    KNP5          -> K.Begin-    (KASCII c)    -> K.Char c+    KCenter       -> K.Begin+    KIns          -> K.Insert+    (KChar c)     -> K.Char c     _             -> K.Unknown (tshow n)  -- | Translates modifiers to our own encoding.@@ -113,7 +150,7 @@ -- settings this is needed or not and the characters really get bold or not. -- HSCurses does this by default, but in Vty you have to request the hack. hack :: Color.Color -> Attr -> Attr-hack c a = if Color.isBright c then with_style a bold else a+hack c a = if Color.isBright c then withStyle a bold else a  setAttr :: Color.Attr -> Attr setAttr Color.Attr{fg, bg} =@@ -122,8 +159,8 @@ --  then def_attr --  else   hack fg $ hack bg $-    def_attr { attr_fore_color = SetTo (aToc fg)-             , attr_back_color = SetTo (aToc bg) }+    defAttr { attrForeColor = SetTo (aToc fg)+            , attrBackColor = SetTo (aToc bg) }  aToc :: Color.Color -> Color aToc Color.Black     = black@@ -134,11 +171,11 @@ aToc Color.Magenta   = magenta aToc Color.Cyan      = cyan aToc Color.White     = white-aToc Color.BrBlack   = bright_black-aToc Color.BrRed     = bright_red-aToc Color.BrGreen   = bright_green-aToc Color.BrYellow  = bright_yellow-aToc Color.BrBlue    = bright_blue-aToc Color.BrMagenta = bright_magenta-aToc Color.BrCyan    = bright_cyan-aToc Color.BrWhite   = bright_white+aToc Color.BrBlack   = brightBlack+aToc Color.BrRed     = brightRed+aToc Color.BrGreen   = brightGreen+aToc Color.BrYellow  = brightYellow+aToc Color.BrBlue    = brightBlue+aToc Color.BrMagenta = brightMagenta+aToc Color.BrCyan    = brightCyan+aToc Color.BrWhite   = brightWhite

@@ -37,8 +37,8 @@   Move v -> fmap anyToUI <$> moveRunHuman False v   Run v -> fmap anyToUI <$> moveRunHuman True v   Wait -> Right <$> fmap ReqUITimed waitHuman-  MoveItem cLegalRaw toCStore verb _ auto ->-    fmap ReqUITimed <$> moveItemHuman cLegalRaw toCStore verb auto+  MoveItem cLegalRaw toCStore mverb _ auto ->+    fmap ReqUITimed <$> moveItemHuman cLegalRaw toCStore mverb auto   Project ts -> fmap ReqUITimed <$> projectHuman ts   Apply ts -> fmap ReqUITimed <$> applyHuman ts   AlterDir ts -> fmap ReqUITimed <$> alterDirHuman ts

@@ -1,6 +1,9 @@-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DataKinds, GADTs #-} -- | Semantics of 'Command.Cmd' client commands that return server commands. -- A couple of them do not take time, the rest does.+-- Here prompts and menus and displayed, but any feedback resulting+-- from the commands (e.g., from inventory manipulation) is generated later on,+-- for all clients that witness the results of the commands. -- TODO: document module Game.LambdaHack.Client.UI.HandleHumanGlobalClient   ( -- * Commands that usually take time@@ -39,11 +42,8 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Item-import Game.LambdaHack.Common.ItemDescription import Game.LambdaHack.Common.ItemStrongest import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Level@@ -56,8 +56,10 @@ import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind-import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Content.TileKind (TileKind)+import qualified Game.LambdaHack.Content.TileKind as TK  -- * Move and Run @@ -87,7 +89,7 @@         runStopOrCmd <- moveRunAid leader dir         case runStopOrCmd of           Left stopMsg -> failWith stopMsg-          Right runCmd -> do+          Right runCmd@(RequestAnyAbility ReqMove{}) -> do             sel <- getsClient sselected             let runMembers = if noRunWithMulti fact                              then [leader]  -- TODO: warn?@@ -99,6 +101,8 @@                                       , runInitDir = Just dir }             when run $ modifyClient $ \cli -> cli {srunning = Just runParams}             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@@ -116,7 +120,7 @@         -- We always see actors from our own faction.         if bfid tb == bfid sb && not (bproj tb) then do           let autoLvl = snd $ autoDungeonLevel fact-          if autoLvl then failWith msgNoChangeLvlLeader+          if autoLvl then failSer NoChangeLvlLeader           else do             -- Select adjacent actor by bumping into him. Takes no time.             success <- pickLeader True target@@ -164,8 +168,11 @@   tb <- getsState $ getActorBody target   tfact <- getsState $ (EM.! bfid tb) . sfactionD   activeItems <- activeItemsClient target-  disp <- getsState $ dispEnemy leader (Just leader) target activeItems-  let spos = bpos sb+  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+      spos = bpos sb       tpos = bpos tb       adj = checkAdjacent sb tb       atWar = isAtWar tfact (bfid sb)@@ -174,6 +181,8 @@           && actorDying tb then failSer DisplaceDying   else if not (bproj tb) && atWar           && braced tb then failSer DisplaceBraced+  else if not (bproj tb) && atWar+          && immobile then failSer DisplaceImmobile   else if not disp && atWar then failSer DisplaceSupported   else do     let lid = blid sb@@ -199,10 +208,11 @@ -- * MoveItem  moveItemHuman :: MonadClientUI m-              => [CStore] -> CStore -> MU.Part -> Bool+              => [CStore] -> CStore -> (Maybe MU.Part) -> Bool               -> m (SlideOrCmd (RequestTimed AbMoveItem))-moveItemHuman cLegalRaw destCStore verb auto = do+moveItemHuman cLegalRaw destCStore mverb auto = do   assert (destCStore `notElem` cLegalRaw) skip+  let verb = fromMaybe (MU.Text $ verbCStore destCStore) mverb   leader <- getLeaderUI   b <- getsState $ getActorBody leader   activeItems <- activeItemsClient leader@@ -217,24 +227,20 @@   case ggi of     Right ((iid, itemFull), CActor _ fromCStore) -> do       let k = itemK itemFull-          msgAndSer toCStore = do-            subject <- partAidLeader leader-            msgAdd $ makeSentence-              [ MU.SubjectVerbSg subject verb, partItemWs k toCStore itemFull ]+          retReq toCStore =             return $ Right $ ReqMoveItem iid k fromCStore toCStore       if fromCStore == CGround       then case destCStore of-        CEqp | goesIntoInv (itemBase itemFull) -> do-          updateItemSlot (Just leader) iid  -- slot not yet assigned-          msgAndSer CInv+        CEqp | goesIntoInv (itemBase itemFull) ->+          retReq CInv         CEqp | eqpOverfull b k -> do           msgAdd $ "Warning:" <+> showReqFailure EqpOverfull <> "."-          updateItemSlot (Just leader) iid  -- slot not yet assigned-          msgAndSer CInv-        _ -> msgAndSer destCStore+          retReq CInv+        _ ->+          retReq destCStore       else case destCStore of         CEqp | eqpOverfull b k -> failSer EqpOverfull-        _ -> msgAndSer destCStore+        _ -> retReq destCStore     Left slides -> return $ Left slides     _ -> assert `failure` ggi @@ -244,12 +250,10 @@              => [Trigger] -> m (SlideOrCmd (RequestTimed AbProject)) projectHuman ts = do   leader <- getLeaderUI-  b <- getsState $ getActorBody leader   tgtPos <- leaderTgtToPos   tgt <- getsClient $ getTarget leader   case tgtPos of     Nothing -> failWith "last target invalid"-    Just pos | pos == bpos b -> failWith "cannot aim at oneself"     Just pos -> do       -- Set cursor to the personal target, temporarily.       oldCursor <- getsClient scursor@@ -281,51 +285,49 @@   let lid = blid sb       spos = bpos sb   Level{lxsize, lysize} <- getLevel lid-  do-      case bla lxsize lysize eps spos tpos of-        Nothing -> failSer ProjectAimOnself-        Just [] -> assert `failure` "project from the edge of level"-                          `twith` (spos, tpos, sb, ts)-        Just (pos : _) -> do-          lvl <- getLevel lid-          let t = lvl `at` pos-          if not $ Tile.isWalkable cotile t-            then failSer ProjectBlockTerrain-            else do-              actorBlind <--                radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight leader-              mab <- getsState $ posToActor pos lid-              if maybe True (bproj . snd . fst) mab-              then if actorBlind-                   then failSer ProjectBlind-                   else projectEps ts tpos eps-              else failSer ProjectBlockActor+  case bla lxsize lysize eps spos tpos of+    Nothing -> failSer ProjectAimOnself+    Just [] -> assert `failure` "project from the edge of level"+                      `twith` (spos, tpos, sb, ts)+    Just (pos : _) -> do+      lvl <- getLevel lid+      let t = lvl `at` pos+      if not $ Tile.isWalkable cotile t+        then failSer ProjectBlockTerrain+        else do+          mab <- getsState $ posToActor pos lid+          if maybe True (bproj . snd . fst) mab+          then projectEps ts tpos eps+          else failSer ProjectBlockActor  projectEps :: MonadClientUI m            => [Trigger] -> Point -> Int            -> m (SlideOrCmd (RequestTimed AbProject)) projectEps ts tpos eps = do   leader <- getLeaderUI-  sb <- getsState $ getActorBody leader+  b <- getsState $ getActorBody leader+  actorSk <- actorSkillsClient leader+  let skill = EM.findWithDefault 0 AbProject actorSk+  activeItems <- activeItemsClient leader   let cLegal = [CGround, CInv, CEqp]       (verb1, object1) = case ts of         [] -> ("aim", "item")         tr : _ -> (verb tr, object tr)       triggerSyms = triggerSymbols ts-      p item =-        let goodKind = if ' ' `elem` triggerSyms-                       then case strengthEqpSlot item of-                         Just (Effect.EqpSlotAddLight, _) -> True-                         Just _ -> False-                         Nothing -> True-                       else jsymbol item `elem` triggerSyms-            trange = totalRange item-        in goodKind-           && trange >= chessDist (bpos sb) tpos-  ggi <- getGroupItem p object1 verb1 cLegal cLegal+      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+      prompt = makePhrase ["What", object1, "to", verb1]+      promptGeneric = "What item to fling"+  ggi <- getGroupItem (either (const False) id . p) prompt promptGeneric cLegal cLegal   case ggi of-    Right ((iid, _), CActor _ fromCStore) -> do-      return $ Right $ ReqProject tpos eps iid fromCStore+    Right ((iid, itemFull), CActor _ fromCStore) ->+      case p itemFull of+        Left reqFail -> failSer reqFail+        Right _ -> return $ Right $ ReqProject tpos eps iid fromCStore     Left slides -> return $ Left slides     _ -> assert `failure` ggi @@ -340,28 +342,24 @@            => [Trigger] -> m (SlideOrCmd (RequestTimed AbApply)) applyHuman ts = do   leader <- getLeaderUI-  actorBlind <- radiusBlind <$> sumOrganEqpClient Effect.EqpSlotAddSight leader+  b <- getsState $ getActorBody leader+  actorSk <- actorSkillsClient leader+  let skill = EM.findWithDefault 0 AbProject actorSk+  activeItems <- activeItemsClient leader   let cLegal = [CGround, CInv, CEqp]       (verb1, object1) = case ts of         [] -> ("activate", "item")         tr : _ -> (verb tr, object tr)       triggerSyms = triggerSymbols ts-      blindScroll item = jsymbol item == '?' && actorBlind-      p item = not (blindScroll item)-               && if ' ' `elem` triggerSyms-                  then Effect.Applicable `elem` jfeature item-                  else jsymbol item `elem` triggerSyms-  ggi <- getGroupItem p object1 verb1 cLegal cLegal+      p itemFull = permittedApply triggerSyms 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   case ggi of-    Right ((iid, itemFull), CActor _ fromCStore) -> do-      let durable = Effect.Durable `elem` jfeature (itemBase itemFull)-          periodic = isJust-                     $ strengthFromEqpSlot Effect.EqpSlotPeriodic itemFull-      if durable && periodic-        then failSer DurablePeriodicAbuse-        else if (blindScroll $ itemBase itemFull)-             then failSer ApplyBlind-             else return $ Right $ ReqApply iid fromCStore+    Right ((iid, itemFull), CActor _ fromCStore) ->+      case p itemFull of+        Left reqFail -> failSer reqFail+        Right _ -> return $ Right $ ReqApply iid fromCStore     Left slides -> return $ Left slides     _ -> assert `failure` ggi @@ -377,7 +375,7 @@         tr : _ -> verb tr       keys = zipWith K.KM (repeat K.NoModifier)                           (K.dirAllKey configVi configLaptop)-      prompt = makePhrase ["What to", verb1 MU.:> "? [movement key"]+      prompt = makePhrase ["What to", verb1 <> "? [movement key"]   me <- displayChoiceUI prompt emptyOverlay keys   case me of     Left slides -> failSlides slides@@ -399,19 +397,19 @@     [] -> failWith $ guessAlter cops alterFeats t     feat : _ -> return $ Right $ ReqAlter tpos $ Just feat -alterFeatures :: [Trigger] -> [F.Feature]+alterFeatures :: [Trigger] -> [TK.Feature] alterFeatures [] = [] alterFeatures (AlterFeature{feature} : ts) = feature : alterFeatures ts alterFeatures (_ : ts) = alterFeatures ts  -- | Guess and report why the bump command failed.-guessAlter :: Kind.COps -> [F.Feature] -> Kind.Id TileKind -> Msg-guessAlter Kind.COps{cotile} (F.OpenTo _ : _) t+guessAlter :: Kind.COps -> [TK.Feature] -> Kind.Id TileKind -> Msg+guessAlter Kind.COps{cotile} (TK.OpenTo _ : _) t   | Tile.isClosable cotile t = "already open"-guessAlter _ (F.OpenTo _ : _) _ = "cannot be opened"-guessAlter Kind.COps{cotile} (F.CloseTo _ : _) t+guessAlter _ (TK.OpenTo _ : _) _ = "cannot be opened"+guessAlter Kind.COps{cotile} (TK.CloseTo _ : _) t   | Tile.isOpenable cotile t = "already closed"-guessAlter _ (F.CloseTo _ : _) _ = "cannot be closed"+guessAlter _ (TK.CloseTo _ : _) _ = "cannot be closed" guessAlter _ _ _ = "never mind"  -- * TriggerTile@@ -423,12 +421,12 @@   tgtMode <- getsClient stgtMode   if isJust tgtMode then do     let getK tfs = case tfs of-          TriggerFeature {feature = F.Cause (Effect.Ascend k)} : _ -> Just k+          TriggerFeature {feature = TK.Cause (IK.Ascend k)} : _ -> Just k           _ : rest -> getK rest           [] -> Nothing         mk = getK ts     case mk of-      Nothing -> failWith  "never mind"+      Nothing -> failWith "never mind"       Just k -> fmap Left $ tgtAscendHuman k   else triggerTile ts @@ -450,16 +448,16 @@         Right () -> return $ Right $ ReqTrigger $ Just feat         Left slides -> return $ Left slides -triggerFeatures :: [Trigger] -> [F.Feature]+triggerFeatures :: [Trigger] -> [TK.Feature] triggerFeatures [] = [] triggerFeatures (TriggerFeature{feature} : ts) = feature : triggerFeatures ts triggerFeatures (_ : ts) = triggerFeatures ts  -- | Verify important feature triggers, such as fleeing the dungeon. verifyTrigger :: MonadClientUI m-              => ActorId -> F.Feature -> m (SlideOrCmd ())+              => ActorId -> TK.Feature -> m (SlideOrCmd ()) verifyTrigger leader feat = case feat of-  F.Cause Effect.Escape{} -> do+  TK.Cause IK.Escape{} -> do     b <- getsState $ getActorBody leader     side <- getsClient sside     fact <- getsState $ (EM.! side) . sfactionD@@ -484,13 +482,13 @@   _ -> return $ Right ()  -- | Guess and report why the bump command failed.-guessTrigger :: Kind.COps -> [F.Feature] -> Kind.Id TileKind -> Msg-guessTrigger Kind.COps{cotile} fs@(F.Cause (Effect.Ascend k) : _) t-  | Tile.hasFeature cotile (F.Cause (Effect.Ascend (-k))) t =+guessTrigger :: Kind.COps -> [TK.Feature] -> Kind.Id TileKind -> Msg+guessTrigger Kind.COps{cotile} fs@(TK.Cause (IK.Ascend k) : _) t+  | Tile.hasFeature cotile (TK.Cause (IK.Ascend (-k))) t =     if k > 0 then "the way goes down, not up"     else if k < 0 then "the way goes up, not down"     else assert `failure` fs-guessTrigger _ fs@(F.Cause (Effect.Ascend k) : _) _ =+guessTrigger _ fs@(TK.Cause (IK.Ascend k) : _) _ =     if k > 0 then "cannot ascend"     else if k < 0 then "cannot descend"     else assert `failure` fs@@ -525,23 +523,28 @@  -- * GameRestart; does not take time -gameRestartHuman :: MonadClientUI m => GroupName -> m (SlideOrCmd RequestUI)+gameRestartHuman :: MonadClientUI m => GroupName ModeKind -> m (SlideOrCmd RequestUI) gameRestartHuman t = do-  let msg = "You just requested a new" <+> tshow t <+> "game."-  b1 <- displayMore ColorFull msg-  if not b1 then failWith "never mind"+  let restart = do+        leader <- getLeaderUI+        DebugModeCli{sdifficultyCli} <- getsClient sdebugCli+        Config{configHeroNames} <- askConfig+        return $ Right+               $ ReqUIGameRestart leader t sdifficultyCli configHeroNames+  escAI <- getsClient sescAI+  if escAI == EscAIExited then restart   else do-    b2 <- displayYesNo ColorBW-            "Current progress will be lost! Really restart the game?"-    msg2 <- rndToAction $ oneOf-              [ "Yea, would be a pity to leave them all to die."-              , "Yea, a shame to get your own team stranded." ]-    if not b2 then failWith msg2+    let msg = "You just requested a new" <+> tshow t <+> "game."+    b1 <- displayMore ColorFull msg+    if not b1 then failWith "never mind"     else do-      leader <- getLeaderUI-      DebugModeCli{sdifficultyCli} <- getsClient sdebugCli-      Config{configHeroNames} <- askConfig-      return $ Right $ ReqUIGameRestart leader t sdifficultyCli configHeroNames+      b2 <- displayYesNo ColorBW+              "Current progress will be lost! Really restart the game?"+      msg2 <- rndToAction $ oneOf+                [ "Yea, would be a pity to leave them all to die."+                , "Yea, a shame to get your own team stranded." ]+      if not b2 then failWith msg2+      else restart  -- * GameExit; does not take time @@ -558,6 +561,8 @@  gameSaveHuman :: MonadClientUI m => m RequestUI gameSaveHuman = do+  -- Announce before the saving started, since it can take some time+  -- and may slow down the machine, even if not block the client.   -- TODO: do not save to history:   msgAdd "Saving game backup."   return ReqUIGameSave@@ -589,7 +594,10 @@ automateHuman = do   -- BFS is not updated while automated, which would lead to corruption.   modifyClient $ \cli -> cli {stgtMode = Nothing}-  go <- displayMore ColorBW "Ceding control to AI (ESC to regain)."-  if not go-    then failWith "Automation canceled."-    else return $ Right ReqUIAutomate+  escAI <- getsClient sescAI+  if escAI == EscAIExited then return $ Right ReqUIAutomate+  else do+    go <- displayMore ColorBW "Ceding control to AI (ESC to regain)."+    if not go+      then failWith "Automation canceled."+      else return $ Right ReqUIAutomate

@@ -46,9 +46,7 @@ import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.ClientOptions-import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction-import qualified Game.LambdaHack.Common.Feature as F import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemDescription import qualified Game.LambdaHack.Common.Kind as Kind@@ -63,9 +61,9 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind+import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.RuleKind-import Game.LambdaHack.Content.TileKind+import qualified Game.LambdaHack.Content.TileKind as TK  -- * GameDifficultyCycle @@ -114,25 +112,31 @@ describeItemHuman :: MonadClientUI m => CStore -> m Slideshow describeItemHuman cstore = do   leader <- getLeaderUI-  describeItemC $ CActor leader cstore+  describeItemC (CActor leader cstore) False -describeItemC :: MonadClientUI m => Container -> m Slideshow-describeItemC c = do+describeItemC :: MonadClientUI m => Container -> Bool -> m Slideshow+describeItemC c noEnter = do   let subject body = partActor body       verbSha body activeItems = if calmEnough body activeItems                                  then "notice"                                  else "paw distractedly"-      shaBlurb body activeItems = makePhrase-        [MU.Capitalize-         $ MU.SubjectVerbSg (subject body) (verbSha body activeItems)]-      stdBlurb body = makePhrase-        [MU.Capitalize $ MU.SubjectVerbSg (subject body) "see"]-  itemToF <- itemToFullClient-  let verb = "describe"-  ggi <- getStoreItem shaBlurb stdBlurb verb c+      prompt body activeItems c2 = case c2 of+        CActor _ CSha ->+          makePhrase+            [MU.Capitalize+             $ MU.SubjectVerbSg (subject body) (verbSha body activeItems)]+        CTrunk{} ->+          makePhrase+            [MU.Capitalize $ MU.SubjectVerbSg (subject body) "recall"]+        _ ->+          makePhrase+            [MU.Capitalize $ MU.SubjectVerbSg (subject body) "see"]+  ggi <- getStoreItem prompt c noEnter   case ggi of-    Right ((iid, _), _) ->-      overlayToSlideshow "" $ itemDesc (storeFromC c) (itemToF iid 1)+    Right ((_, itemFull), c2) -> do+      lid2 <- getsState $ lidFromC c2+      localTime <- getsState $ getLocalTime lid2+      overlayToSlideshow "" $ itemDesc c2 lid2 localTime itemFull     Left slides -> return slides  -- * AllOwned@@ -142,7 +146,7 @@ allOwnedHuman = do   leader <- getLeaderUI   b <- getsState $ getActorBody leader-  describeItemC $ CTrunk (bfid b) (blid b) (bpos b)+  describeItemC (CTrunk (bfid b) (blid b) (bpos b)) False  -- * SelectActor @@ -214,12 +218,12 @@       let slastRecord = ([], [], maxK)       modifyClient $ \cli -> cli {slastRecord}       promptToSlideshow $ "Macro will be recorded for up to"-                          <+> tshow maxK <+> "steps."+                          <+> tshow maxK <+> "actions."  -- no MU, poweruser     _ -> do       let slastRecord = (seqPrevious, [], 0)       modifyClient $ \cli -> cli {slastRecord}       promptToSlideshow $ "Macro recording interrupted after"-                          <+> tshow (maxK - k - 1) <+> "steps."+                          <+> tshow (maxK - k - 1) <+> "actions."  -- * History @@ -229,11 +233,13 @@   arena <- getArenaUI   local <- getsState $ getLocalTime arena   global <- getsState stime-  let msg = makeSentence+  let turnsGlobal = global `timeFitUp` timeTurn+      turnsLocal = local `timeFitUp` timeTurn+      msg = makeSentence         [ "You survived for"-        , MU.CarWs (global `timeFitUp` timeTurn) "half-second turn"+        , MU.CarWs turnsGlobal "half-second turn"         , "(this level:"-        , MU.Text (tshow (local `timeFitUp` timeTurn)) MU.:> ")" ]+        , MU.Text (tshow turnsLocal) <> ")" ]         <+> "Past messages:"   overlayToBlankSlideshow msg $ renderHistory history @@ -272,6 +278,7 @@ mainMenuHuman :: MonadClientUI m => m Slideshow mainMenuHuman = do   Kind.COps{corule} <- getsState scops+  escAI <- getsClient sescAI   Binding{brevMap, bcmdList} <- askBinding   scurDifficulty <- getsClient scurDifficulty   DebugModeCli{sdifficultyCli} <- getsClient sdebugCli@@ -291,7 +298,10 @@                    | (km, (desc, [HumanCmd.CmdMenu], cmd)) <- bcmdList,                      cmd /= HumanCmd.GameDifficultyCycle ]         in [-             (fst (revLookup HumanCmd.Cancel), "back to playing")+             if escAI == EscAIMenu then+               (fst (revLookup HumanCmd.Automate), "back to screensaver")+             else+               (fst (revLookup HumanCmd.Cancel), "back to playing")            , (fst (revLookup HumanCmd.Accept), "see more help")            ]            ++ cmds@@ -387,9 +397,9 @@                      verb = "be here"                      desc = if not (null rest)  -- many actors                             then ""-                            else case itemDisco $ itemToF (btrunk body) 1 of+                            else case itemDisco $ itemToF (btrunk body) (1, []) of                               Nothing -> ""-                              Just ItemDisco{itemKind} -> idesc itemKind+                              Just ItemDisco{itemKind} -> IK.idesc itemKind                      pdesc = if desc == "" then "" else "(" <> desc <> ")"                  in makeSentence [MU.SubjectVerbSg subject verb] <+> pdesc           vis | lvl `at` p == unknownId = "that is"@@ -399,7 +409,7 @@       -- Show general info about current position.       lookMsg <- lookAt True vis canSee p leader enemyMsg       -- Check if there's something lying around at current position.-      let is = lvl `atI` p+      is <- getsState $ getCBag $ CFloor lidV p       if EM.size is <= 2 then         promptToSlideshow lookMsg       else do@@ -408,7 +418,7 @@  -- | Create a list of item names. floorItemOverlay :: MonadClientUI m => LevelId -> Point -> m Slideshow-floorItemOverlay lid p = describeItemC (CFloor lid p)+floorItemOverlay lid p = describeItemC (CFloor lid p) True  -- * TgtFloor @@ -542,7 +552,7 @@         Nothing -> Nothing         Just cpos ->           let tile = lvl `at` cpos-          in if Tile.hasFeature cotile (F.Cause $ Effect.Ascend k) tile+          in if Tile.hasFeature cotile (TK.Cause $ IK.Ascend k) tile              then Just cpos              else Nothing   case rightStairs of@@ -551,10 +561,10 @@       assert (nln /= lidV `blame` "stairs looped" `twith` nln) skip       nlvl <- getLevel nln       -- Do not freely reveal the other end of the stairs.-      let ascDesc (F.Cause (Effect.Ascend _)) = True+      let ascDesc (TK.Cause (IK.Ascend _)) = True           ascDesc _ = False           scursor =-            if any ascDesc $ tfeature $ okind (nlvl `at` npos)+            if any ascDesc $ TK.tfeature $ okind (nlvl `at` npos)             then TPoint nln npos  -- already known as an exit, focus on it             else scursorOld  -- unknown, do not reveal       modifyClient $ \cli -> cli {scursor, stgtMode = Just (TgtMode nln)}

@@ -5,13 +5,16 @@   ) where  import Control.Exception.Assert.Sugar+import Data.Maybe import Data.Text (Text) import qualified NLP.Miniutter.English as MU -import qualified Game.LambdaHack.Common.Feature as F+import Game.LambdaHack.Common.Actor (verbCStore) import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Vector+import Game.LambdaHack.Content.ModeKind+import qualified Game.LambdaHack.Content.TileKind as TK  data CmdCategory =     CmdMenu | CmdMove | CmdItem | CmdTgt | CmdAuto | CmdMeta@@ -35,14 +38,14 @@     Move !Vector   | Run !Vector   | Wait-  | MoveItem ![CStore] !CStore !MU.Part !MU.Part !Bool+  | MoveItem ![CStore] !CStore !(Maybe MU.Part) !MU.Part !Bool   | Project     ![Trigger]   | Apply       ![Trigger]   | AlterDir    ![Trigger]   | TriggerTile ![Trigger]   | StepToTarget     -- Below this line, commands do not take time.-  | GameRestart !GroupName+  | GameRestart !(GroupName ModeKind)   | GameExit   | GameSave   | Tactic@@ -83,8 +86,9 @@  data Trigger =     ApplyItem {verb :: !MU.Part, object :: !MU.Part, symbol :: !Char}-  | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature}-  | TriggerFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !F.Feature}+  | AlterFeature {verb :: !MU.Part, object :: !MU.Part, feature :: !TK.Feature}+  | TriggerFeature+      {verb :: !MU.Part, object :: !MU.Part, feature :: !TK.Feature}   deriving (Show, Read, Eq, Ord)  -- | Commands that are forbidden on a remote level, because they@@ -106,7 +110,9 @@   Move v      -> "move" <+> compassText v   Run v       -> "run" <+> compassText v   Wait        -> "wait"-  MoveItem _ _ verb object _ -> makePhrase [verb, object]+  MoveItem _ store2 mverb object _ ->+    let verb = fromMaybe (MU.Text $ verbCStore store2) mverb+    in makePhrase [verb, object]   Project ts  -> triggerDescription ts   Apply ts    -> triggerDescription ts   AlterDir ts -> triggerDescription ts

@@ -1,8 +1,7 @@ -- | Inventory management and party cycling. -- TODO: document module Game.LambdaHack.Client.UI.InventoryClient-  ( failMsg, msgNoChangeDunLeader, msgNoChangeLvlLeader-  , getGroupItem, getAnyItem, getStoreItem+  ( failMsg, getGroupItem, getAnyItem, getStoreItem   , memberCycle, memberBack, pickLeader   ) where @@ -46,19 +45,31 @@ -- Note that this does not guarantee the chosen item belongs to the group, -- as the player can override the choice. getGroupItem :: MonadClientUI m-             => (Item -> Bool)  -- ^ which items to consider suitable-             -> MU.Part   -- ^ name of the item group-             -> MU.Part   -- ^ the verb describing the action+             => (ItemFull -> Bool)  -- ^ which items to consider suitable+             -> Text      -- ^ specific prompt for only suitable items+             -> Text      -- ^ generic prompt              -> [CStore]  -- ^ initial legal containers              -> [CStore]  -- ^ legal containers after Calm taken into account              -> m (SlideOrCmd ((ItemId, ItemFull), Container))-getGroupItem p itemsName verb cLegalRaw cLegalAfterCalm = do+getGroupItem psuit prompt promptGeneric cLegalRaw cLegalAfterCalm = do+  side <- getsClient sside   leader <- getLeaderUI+  let aidNotEmpty store aid = do+        bag <- getsState $ getCBag (CActor aid store)+        return $! not $ EM.null bag+      partyNotEmpty store = do+        as <- getsState $ fidActorNotProjAssocs side+        bs <- mapM (aidNotEmpty store . fst) as+        return $! or bs+  -- Don't display stores empty for all actors+  cLegalNotEmpty <- filterM partyNotEmpty cLegalAfterCalm+  -- Move a store that is empty for this actor to the back.   getCStoreBag <- getsState $ \s cstore -> getCBag (CActor leader cstore) s-  let cNotEmpty = not . EM.null . getCStoreBag-      cLegal = filter cNotEmpty cLegalAfterCalm  -- don't display empty stores-      tsuitable = const $ makePhrase [MU.Capitalize (MU.Ws itemsName)]-  getItem p (\b _ -> tsuitable b) tsuitable verb+  let hasThisActor = not . EM.null . getCStoreBag+      cLegal = case find hasThisActor cLegalAfterCalm of+        Nothing -> cLegalNotEmpty+        Just cThisActor -> cThisActor : delete cThisActor cLegalNotEmpty+  getItem psuit (\_ _ _ -> prompt) (\_ _ _ -> promptGeneric)           (map (CActor leader) cLegalRaw)           (map (CActor leader) cLegal)           True INone@@ -75,10 +86,11 @@            -> m (SlideOrCmd ((ItemId, ItemFull), Container)) getAnyItem verb cLegalRaw cLegalAfterCalm askWhenLone askNumber = do   leader <- getLeaderUI-  soc <- getItem (const True) (\_ _ -> "Items") (const "Items") verb+  let prompt = makePhrase ["What to", verb]+  soc <- getItem (const True) (\_ _ _ -> prompt) (\_ _ _ -> prompt)                  (map (CActor leader) cLegalRaw)                  (map (CActor leader) cLegalAfterCalm)-                 askWhenLone INone+                 askWhenLone ISuitable   case soc of     Left _ -> return soc     Right ((iid, itemFull), c) -> do@@ -91,76 +103,73 @@ -- | Display all items from a store and let the human player choose any -- or switch to any other store. getStoreItem :: MonadClientUI m-             => (Actor -> [ItemFull] -> Text)-                                 -- ^ how to describe suitable items in CSha-             -> (Actor -> Text)  -- ^ how to describe suitable items elsewhere-             -> MU.Part          -- ^ the verb describing the action+             => (Actor -> [ItemFull] -> Container -> Text)+                                 -- ^ how to describe suitable items              -> Container        -- ^ initial container+             -> Bool             -- ^ whether Enter should be disabled              -> m (SlideOrCmd ((ItemId, ItemFull), Container))-getStoreItem shaBlurb stdBlurb verb cInitial = do+getStoreItem prompt cInitial noEnter = do   leader <- getLeaderUI   let allStores = map (CActor leader) [CEqp, CInv, CSha, CGround]       cLegalRaw = cInitial : delete cInitial allStores-  getItem (const True) shaBlurb stdBlurb verb cLegalRaw cLegalRaw-          True ISuitable+      dialogState = if noEnter then INoEnter else ISuitable+  getItem (const True) prompt prompt cLegalRaw cLegalRaw+          True dialogState -data ItemDialogState = INone | ISuitable | IAll+data ItemDialogState = INone | ISuitable | IAll | INoEnter   deriving (Show, Eq)  -- | Let the human player choose a single, preferably suitable, -- item from a list of items. getItem :: MonadClientUI m-        => (Item -> Bool)   -- ^ which items to consider suitable-        -> (Actor -> [ItemFull] -> Text)-                            -- ^ how to describe suitable items in CSha-        -> (Actor -> Text)  -- ^ how to describe suitable items elsewhere-        -> MU.Part          -- ^ the verb describing the action+        => (ItemFull -> Bool)  -- ^ which items to consider suitable+        -> (Actor -> [ItemFull] -> Container -> Text)+                            -- ^ specific prompt for only suitable items+        -> (Actor -> [ItemFull] -> Container -> Text)+                            -- ^ generic prompt         -> [Container]      -- ^ initial legal containers         -> [Container]      -- ^ legal containers with Calm taken into account         -> Bool             -- ^ whether to ask, when the only item                             --   in the starting container is suitable         -> ItemDialogState  -- ^ the dialog state to start in         -> m (SlideOrCmd ((ItemId, ItemFull), Container))-getItem p tshaSuit tsuitable verb cLegalRaw cLegal askWhenLone initalState = do+getItem psuit prompt promptGeneric cLegalRaw cLegal askWhenLone initalState = do   leader <- getLeaderUI   accessCBag <- getsState $ flip getCBag   let storeAssocs = EM.assocs . accessCBag       allAssocs = concatMap storeAssocs cLegal       rawAssocs = concatMap storeAssocs cLegalRaw+  mapM_ (updateItemSlot (Just leader)) $+    concatMap (EM.keys . accessCBag) cLegal   case (cLegal, allAssocs) of     ([cStart], [(iid, k)]) | not askWhenLone -> do       itemToF <- itemToFullClient       return $ Right ((iid, itemToF iid k), cStart)-    (_ : _, _ : _) -> do-      let groundCs = filter ((== CGround) . storeFromC) cLegal-      mapM_ (updateItemSlot (Just leader)) $-        concatMap (EM.keys . accessCBag) groundCs-      transition p tshaSuit tsuitable verb cLegal initalState+    (_ : _, _ : _) ->+      transition psuit prompt promptGeneric cLegal initalState     _ -> if null rawAssocs then do            let tLegal = map (MU.Text . ppContainer) cLegalRaw                ppLegal = makePhrase [MU.WWxW "nor" tLegal]            failWith $ "no items" <+> ppLegal          else failSer ItemNotCalm --- TODO: m is no longer needed and perhaps this can be simplified even more data DefItemKey m = DefItemKey-  { defLabel  :: Text-  , defCond   :: Bool+  { defLabel  :: Text  -- ^ can be undefined if not @defCond@+  , defCond   :: !Bool   , defAction :: K.Key -> m (SlideOrCmd ((ItemId, ItemFull), Container))   }  transition :: forall m. MonadClientUI m-           => (Item -> Bool)   -- ^ which items to consider suitable-           -> (Actor -> [ItemFull] -> Text)-                               -- ^ how to describe suitable items in CSha-           -> (Actor -> Text)  -- ^ how to describe suitable items elsewhere-           -> MU.Part          -- ^ the verb describing the action+           => (ItemFull -> Bool)  -- ^ which items to consider suitable+           -> (Actor -> [ItemFull] -> Container -> Text)+                            -- ^ specific prompt for only suitable items+           -> (Actor -> [ItemFull] -> Container -> Text)+                            -- ^ generic prompt            -> [Container]            -> ItemDialogState            -> m (SlideOrCmd ((ItemId, ItemFull), Container))-transition _ _ _ verb [] iDS = assert `failure` (verb, iDS)-transition psuit tshaSuit tsuitable verb-           cLegal@(cCur:cRest) itemDialogState = do+transition _ _ _ [] iDS = assert `failure` iDS+transition psuit prompt promptGeneric cLegal@(cCur:cRest) itemDialogState = do   (letterSlots, numberSlots) <- getsClient sslots   leader <- getLeaderUI   body <- getsState $ getActorBody leader@@ -171,31 +180,34 @@   itemToF <- itemToFullClient   let getResult :: ItemId -> ((ItemId, ItemFull), Container)       getResult iid = ((iid, itemToF iid (bag EM.! iid)), cCur)-      filterP s iid _ = psuit (getItemBody iid s)-  bagSuit <- getsState $ \s -> EM.filterWithKey (filterP s) bag-  let bagLetterSlots = EM.filter (`EM.member` bag) letterSlots+      filterP iid kit = psuit $ itemToF iid kit+      bagSuit = EM.filterWithKey filterP bag+      bagLetterSlots = EM.filter (`EM.member` bag) letterSlots       bagNumberSlots = IM.filter (`EM.member` bag) numberSlots       suitableLetterSlots = EM.filter (`EM.member` bagSuit) letterSlots       (autoDun, autoLvl) = autoDungeonLevel fact+      normalizeState INoEnter = INone+      normalizeState x = x       keyDefs :: [(K.Key, DefItemKey m)]       keyDefs = filter (defCond . snd)         [ (K.Char '?', DefItemKey            { defLabel = "?"            , defCond = True-           , defAction = \_ -> case itemDialogState of+           , defAction = \_ -> case normalizeState itemDialogState of                INone ->                  if EM.null bagSuit-                 then transition psuit tshaSuit tsuitable verb cLegal IAll-                 else transition psuit tshaSuit tsuitable verb cLegal ISuitable+                 then transition psuit prompt promptGeneric cLegal IAll+                 else transition psuit prompt promptGeneric cLegal ISuitable                ISuitable | bag /= bagSuit ->-                 transition psuit tshaSuit tsuitable verb cLegal IAll-               _ -> transition psuit tshaSuit tsuitable verb cLegal INone+                 transition psuit prompt promptGeneric cLegal IAll+               _ -> transition psuit prompt promptGeneric cLegal INone            })         , (K.Char '/', DefItemKey            { defLabel = "/"            , defCond = length cLegal > 1-           , defAction = \_ -> transition psuit tshaSuit tsuitable verb-                                          (cRest ++ [cCur]) itemDialogState+           , defAction = \_ ->+               transition psuit prompt promptGeneric+                          (cRest ++ [cCur]) (normalizeState itemDialogState)            })         , (K.Return,            let enterSlots = if itemDialogState == IAll@@ -206,7 +218,8 @@                Nothing -> assert `failure` "no suitable items"                                  `twith` enterSlots                Just ((l, _), _) -> "RET(" <> T.singleton (slotChar l) <> ")"-           , defCond = not $ EM.null enterSlots+           , defCond = not (EM.null enterSlots+                            || itemDialogState == INoEnter)            , defAction = \_ -> case EM.maxView enterSlots of                Nothing -> assert `failure` "no suitable items"                                  `twith` enterSlots@@ -233,7 +246,10 @@                      CActor _ cstore -> CActor newLeader cstore                      _ -> c                    newLegal = map newC cLegal-               transition psuit tshaSuit tsuitable verb newLegal itemDialogState+               accessCBag <- getsState $ flip getCBag+               mapM_ (updateItemSlot (Just newLeader)) $+                 concatMap (EM.keys . accessCBag) newLegal+               transition psuit prompt promptGeneric newLegal itemDialogState            })         , (K.BackTab, DefItemKey            { defLabel = "SHIFT-TAB"@@ -246,7 +262,10 @@                      CActor _ cstore -> CActor newLeader cstore                      _ -> c                    newLegal = map newC cLegal-               transition psuit tshaSuit tsuitable verb newLegal itemDialogState+               accessCBag <- getsState $ flip getCBag+               mapM_ (updateItemSlot (Just newLeader)) $+                 concatMap (EM.keys . accessCBag) newLegal+               transition psuit prompt promptGeneric newLegal itemDialogState            })         ]       lettersDef :: DefItemKey m@@ -261,22 +280,19 @@             _ -> assert `failure` "unexpected key:" `twith` K.showKey key         }       ppCur = ppContainer cCur-      tsuit = if storeFromC cCur == CSha-              then tshaSuit body activeItems-              else tsuitable body-      (labelLetterSlots, bagFiltered, prompt) =+      (labelLetterSlots, bagFiltered, promptChosen) =         case itemDialogState of-          INone     -> (suitableLetterSlots,-                        EM.empty,-                        makePhrase ["What to", verb] <+> ppCur <> "?")           ISuitable -> (suitableLetterSlots,                         bagSuit,-                        tsuit <+> ppCur <> ":")+                        prompt body activeItems cCur <+> ppCur <> ":")           IAll      -> (bagLetterSlots,                         bag,-                        "Items" <+> ppCur <> ":")-  io <- itemOverlay (storeFromC cCur) bagFiltered-  runDefItemKey keyDefs lettersDef io labelLetterSlots prompt+                        promptGeneric body activeItems cCur <+> ppCur <> ":")+          _         -> (suitableLetterSlots,+                        EM.empty,+                        prompt body activeItems cCur <+> ppCur <> ":")+  io <- itemOverlay cCur (blid body) bagFiltered+  runDefItemKey keyDefs lettersDef io bagLetterSlots promptChosen  runDefItemKey :: MonadClientUI m               => [(K.Key, DefItemKey m)]@@ -357,12 +373,6 @@       success <- pickLeader verbose np       assert (success `blame` "same leader" `twith` (leader, np, b)) skip       return mempty--msgNoChangeDunLeader :: Msg-msgNoChangeDunLeader = "level change is automatic for your team"--msgNoChangeLvlLeader :: Msg-msgNoChangeLvlLeader = "leader change is automatic for your team"  partyAfterLeader :: MonadStateRead m => ActorId -> m [(ActorId, Actor)] partyAfterLeader leader = do

@@ -12,7 +12,7 @@   , displayFrame, displayDelay, displayFrames, displayActorStart, drawOverlay     -- * Assorted primitives   , stopPlayBack, stopRunning, askConfig, askBinding-  , syncFrames, tryTakeMVarSescMVar, scoreToSlideshow+  , syncFrames, setFrontAutoYes, tryTakeMVarSescMVar, scoreToSlideshow   , getLeaderUI, getArenaUI, viewedLevel   , targetDescLeader, targetDescCursor   , leaderTgtToPos, leaderTgtAims, cursorToPos@@ -42,7 +42,7 @@ import Game.LambdaHack.Client.UI.KeyBindings import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState-import qualified Game.LambdaHack.Common.Effect as Effect+import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Common.Faction import qualified Game.LambdaHack.Common.HighScore as HighScore import Game.LambdaHack.Common.ItemDescription@@ -219,6 +219,9 @@   km <- readConnFrontend   assert (km == K.spaceKM) skip +setFrontAutoYes :: MonadClientUI m => Bool -> m ()+setFrontAutoYes b = writeConnFrontend $ FrontAutoYes b+ tryTakeMVarSescMVar :: MonadClientUI m => m Bool tryTakeMVarSescMVar = do   mescMVar <- getsSession sescMVar@@ -226,7 +229,7 @@     Nothing -> return False     Just escMVar -> do       mUnit <- liftIO $ tryTakeMVar escMVar-      return $ isJust mUnit+      return $! isJust mUnit  scoreToSlideshow :: MonadClientUI m => Int -> Status -> m Slideshow scoreToSlideshow total status = do@@ -297,7 +300,7 @@     Just (TEnemy aid _) -> do       side <- getsClient sside       b <- getsState $ getActorBody aid-      maxHP <- sumOrganEqpClient Effect.EqpSlotAddMaxHP aid+      maxHP <- sumOrganEqpClient IK.EqpSlotAddMaxHP aid       let percentage = 100 * bhp b `div` xM (max 5 maxHP)           stars | percentage < 20  = "[_____]"                 | percentage < 40  = "[*____]"@@ -316,12 +319,13 @@       pointedText <-         if lid == lidV         then do-          lvl <- getLevel lid-          case EM.assocs $ lvl `atI` p of+          bag <- getsState $ getCBag (CFloor lid p)+          case EM.assocs bag of             [] -> return $! "exact spot" <+> (T.pack . show) p-            [(iid, k)] -> do+            [(iid, kit@(k, _))] -> do+              localTime <- getsState $ getLocalTime lid               itemToF <- itemToFullClient-              let (name, stats) = partItem CGround (itemToF iid k)+              let (name, stats) = partItem (CFloor lid p) lid localTime (itemToF iid kit)               return $! makePhrase $ if k == 1                                      then [name, stats]  -- "a sword" too wordy                                      else [MU.CarWs k name, stats]

@@ -36,7 +36,7 @@ import Game.LambdaHack.Common.Request import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile-import Game.LambdaHack.Content.TileKind+import qualified Game.LambdaHack.Content.TileKind as TK  -- | Add a message to the current report. msgAdd :: MonadClientUI m => Msg -> m ()@@ -49,11 +49,12 @@ -- | Store current report in the history and reset report. recordHistory :: MonadClientUI m => m () recordHistory = do+  time <- getsState stime   StateClient{sreport, shistory} <- getClient   unless (nullReport sreport) $ do     Config{configHistoryMax} <- askConfig     msgReset ""-    let nhistory = takeHistory configHistoryMax $! addReport sreport shistory+    let nhistory = takeHistory configHistoryMax $! addReport shistory time sreport     modifyClient $ \cli -> cli {shistory = nhistory}  type SlideOrCmd a = Either Slideshow a@@ -87,13 +88,14 @@   itemToF <- itemToFullClient   lidV <- viewedLevel   lvl <- getLevel lidV+  localTime <- getsState $ getLocalTime lidV   b <- getsState $ getActorBody aid   subject <- partAidLeader aid-  let is = lvl `atI` pos-      verb = MU.Text $ if pos == bpos b+  is <- getsState $ getCBag $ CFloor lidV pos+  let verb = MU.Text $ if pos == bpos b                        then "stand on"                        else if canSee then "notice" else "remember"-  let nWs (iid, k) = partItemWs k CGround (itemToF iid k)+  let nWs (iid, kit@(k, _)) = partItemWs k (CFloor lidV pos) lidV localTime (itemToF iid kit)       isd = case detailed of               _ | EM.size is == 0 -> ""               _ | EM.size is <= 2 ->@@ -105,7 +107,7 @@       obscured | knownLsecret lvl                  && tile /= hideTile cops lvl pos = "partially obscured"                | otherwise = ""-      tileText = obscured <+> tname (okind tile)+      tileText = obscured <+> TK.tname (okind tile)       tilePart | T.null tilePrefix = MU.Text tileText                | otherwise = MU.AW $ MU.Text tileText       tileDesc = [MU.Text tilePrefix, tilePart]@@ -118,20 +120,25 @@   else return $! msg <+> isd  -- | Create a list of item names.-itemOverlay :: MonadClient m => CStore -> ItemBag -> m Overlay-itemOverlay cstore bag = do+itemOverlay :: MonadClient m+            => Container -> LevelId -> ItemBag -> m Overlay+itemOverlay c lid bag = do+  localTime <- getsState $ getLocalTime lid   itemToF <- itemToFullClient   (letterSlots, numberSlots) <- getsClient sslots+  assert (all (`elem` EM.elems letterSlots ++ IM.elems numberSlots)+              (EM.keys bag)+          `blame` (c, lid, bag, letterSlots, numberSlots)) skip   let pr (l, iid) =         case EM.lookup iid bag of           Nothing -> Nothing-          Just k ->-            let itemFull = itemToF iid k+          Just kit@(k, _) ->+            let itemFull = itemToF iid kit                 -- TODO: add color item symbols as soon as we have a menu                 -- with all items visible on the floor or known to player                 -- symbol = jsymbol $ itemBase itemFull             in Just $ makePhrase [ slotLabel l, "-"  -- MU.String [symbol]-                                 , partItemWs k cstore itemFull ]+                                 , partItemWs k c lid localTime itemFull ]                            <> " "   return $! toOverlay $ mapMaybe pr     $ map (first Left) (EM.assocs letterSlots)

@@ -35,7 +35,7 @@ import Game.LambdaHack.Common.State import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.TileKind+import qualified Game.LambdaHack.Content.TileKind as TK  -- | Continue running in the given direction. continueRun :: MonadClient m@@ -125,7 +125,7 @@                     || Tile.isOpenable cotile t                     || Tile.isClosable cotile t                     || Tile.isChangeable cotile t) then-          if not $ EM.null $ lvl `atI` tpos then+          if EM.member tpos $ lfloor lvl then             Left $ showReqFailure AlterBlockItem           else             Right $ RequestAnyAbility $ ReqAlter tpos Nothing@@ -138,8 +138,9 @@             -- in hopes of killing a monster lurking within.             -- If the action had a cost, misclicks would incur the cost, too.             -- Right now the player may repeatedly alter tiles trying to learn-            -- about invisible pass-wall actors, but it costs a turn-            -- and does not harm the invisible actors, so it's not tempting.+            -- about invisible pass-wall actors, but when an actor detected,+            -- it costs a turn and does not harm the invisible actors,+            -- so it's not so tempting.        -- Ignore a known boring, not accessible tile.        else Left "never mind"   return $! runStopOrCmd@@ -153,7 +154,7 @@                => ActorId -> Int -> Maybe Vector -> m (Either Msg Vector) continueRunDir aid distLast mdir = do   sreport <- getsClient sreport -- TODO: check the message before it goes into history-  let boringMsgs = map BS.pack [ "You hear some noises."+  let boringMsgs = map BS.pack [ "You hear a distant"                                , "reveals that the" ]       boring repLine = any (`BS.isInfixOf` repLine) boringMsgs       -- TODO: use a regexp from the UI config instead@@ -227,7 +228,7 @@   let lid = blid body   lvl <- getLevel lid   let posHere = bpos body-      posHasItems pos = not $ EM.null $ lvl `atI` pos+      posHasItems pos = EM.member pos $ lfloor lvl       posThere = posHere `shift` dir   actorsThere <- getsState $ posToActors posThere lid   let posLast = boldpos body@@ -258,7 +259,7 @@       rightTilesLast = map (lvl `at`) rightPsLast       leftForwardTileHere = lvl `at` leftForwardPosHere       rightForwardTileHere = lvl `at` rightForwardPosHere-      featAt = actionFeatures smarkSuspect . okind+      featAt = TK.actionFeatures smarkSuspect . okind       terrainChangeMiddle = null (Tile.causeEffects cotile tileThere)                               -- step into; will stop next turn due to message                             && featAt tileThere

@@ -109,12 +109,20 @@ -- of the screen are displayed below. As many slides as needed are shown. overlayToSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow overlayToSlideshow prompt overlay = do+  promptAI <- msgPromptAI   lid <- getArenaUI   Level{lxsize, lysize} <- getLevel lid  -- TODO: screen length or viewLevel   sreport <- getsClient sreport-  let msg = splitReport lxsize (addMsg sreport prompt)+  let msg = splitReport lxsize (prependMsg promptAI (addMsg sreport prompt))   return $! splitOverlay False (lysize + 1) msg overlay +msgPromptAI :: MonadClientUI m => m Msg+msgPromptAI = do+  side <- getsClient sside+  fact <- getsState $ (EM.! side) . sfactionD+  let underAI = isAIFact fact+  return $! if underAI then "[press ESC for Main Menu]" else ""+ overlayToBlankSlideshow :: MonadClientUI m => Msg -> Overlay -> m Slideshow overlayToBlankSlideshow prompt overlay = do   lid <- getArenaUI@@ -135,7 +143,8 @@   bfsmpath <- maybe (return Nothing) pathFromLeader mleader   tgtDesc <- maybe (return ("------", Nothing)) targetDescLeader mleader   cursorDesc <- targetDescCursor-  let over = renderReport sreport+  promptAI <- msgPromptAI+  let over = renderReport (prependMsg promptAI sreport)       topLineOnly = truncateToOverlay over   basicFrame <-     draw False ColorFull arena cursorPos tgtPos

@@ -8,10 +8,11 @@   , Actor(..), ResDelta(..)   , deltaSerious, deltaMild, xM, minusM, minusTwoM, oneM   , bspeed, actorTemplate, timeShiftFromSpeed, braced, waitedLastTurn-  , actorDying, actorNewBorn, hpTooLow, unoccupied+  , actorDying, actorNewBorn, unoccupied+  , hpTooLow, calmEnough, calmEnough10, hpEnough, hpEnough10     -- * Assorted   , ActorDict, smellTimeout, checkAdjacent-  , mapActorItems_, ppCStore, ppContainer+  , mapActorItems_, ppContainer, ppCStore, verbCStore   ) where  import Control.Exception.Assert.Sugar@@ -23,7 +24,6 @@ import qualified NLP.Miniutter.English as MU  import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest import Game.LambdaHack.Common.Misc@@ -31,6 +31,7 @@ import Game.LambdaHack.Common.Random import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector+import qualified Game.LambdaHack.Content.ItemKind as IK  -- | Actor properties that are changing throughout the game. -- If they are dublets of properties from @ActorKind@,@@ -139,10 +140,10 @@ bspeed b activeItems =   case btrajectory b of     Nothing -> toSpeed $ max 1  -- avoid infinite wait-               $ sumSlotNoFilter Effect.EqpSlotAddSpeed activeItems+               $ sumSlotNoFilter IK.EqpSlotAddSpeed activeItems     Just (_, speed) -> speed --- | Add time taken by a single step at the actor's current speed.+-- | Add time taken by a single 1m step at the actor's current speed. timeShiftFromSpeed :: Actor -> [ItemFull] -> Time -> Time timeShiftFromSpeed b activeItems time =   let speed = bspeed b activeItems@@ -170,9 +171,25 @@  hpTooLow :: Actor -> [ItemFull] -> Bool hpTooLow b activeItems =-  let maxHP = sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems-  in bhp b <= oneM || 5 * bhp b < xM maxHP+  let maxHP = sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems+  in bhp b <= oneM || 5 * bhp b < xM maxHP && bhp b < xM 10 +calmEnough :: Actor -> [ItemFull] -> Bool+calmEnough b activeItems =+  let calmMax = max 1 $ sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems+  in 2 * xM calmMax <= 3 * bcalm b++calmEnough10 :: Actor -> [ItemFull] -> Bool+calmEnough10 b activeItems = calmEnough b activeItems && bcalm b >= xM 10++hpEnough :: Actor -> [ItemFull] -> Bool+hpEnough b activeItems =+  let hpMax = max 1 $ sumSlotNoFilter IK.EqpSlotAddMaxHP activeItems+  in 2 * xM hpMax <= 3 * bhp b++hpEnough10 :: Actor -> [ItemFull] -> Bool+hpEnough10 b activeItems = hpEnough b activeItems && bhp b >= xM 10+ -- | Checks for the presence of actors in a position. -- Does not check if the tile is walkable. unoccupied :: [Actor] -> Point -> Bool@@ -188,11 +205,17 @@ checkAdjacent :: Actor -> Actor -> Bool checkAdjacent sb tb = blid sb == blid tb && adjacent (bpos sb) (bpos tb) -mapActorItems_ :: Monad m => (ItemId -> Int -> m a) -> Actor -> m ()+mapActorItems_ :: Monad m => (ItemId -> ItemQuant -> m a) -> Actor -> m () mapActorItems_ f Actor{binv, beqp, borgan} = do   let is = EM.assocs beqp ++ EM.assocs binv ++ EM.assocs borgan   mapM_ (uncurry f) is +ppContainer :: Container -> Text+ppContainer CFloor{} = "nearby"+ppContainer CEmbed{} = "embedded nearby"+ppContainer (CActor _ cstore) = ppCStore cstore+ppContainer CTrunk{} = "in our possession"+ ppCStore :: CStore -> Text ppCStore CGround = "on the ground" ppCStore COrgan = "among organs"@@ -200,10 +223,12 @@ ppCStore CInv = "in inventory" ppCStore CSha = "in shared stash" -ppContainer :: Container -> Text-ppContainer CFloor{} = "nearby"-ppContainer (CActor _ cstore) = ppCStore cstore-ppContainer CTrunk{} = "in our possession"+verbCStore :: CStore -> Text+verbCStore CGround = "drop"+verbCStore COrgan = "implant"+verbCStore CEqp = "equip"+verbCStore CInv = "pack"+verbCStore CSha = "stash"  instance Binary Actor where   put Actor{..} = do

@@ -6,14 +6,14 @@   , actorAssocsLvl, actorAssocs, actorList   , actorRegularAssocsLvl, actorRegularAssocs, actorRegularList   , bagAssocs, bagAssocsK, calculateTotal-  , sharedAllOwned, sharedAllOwnedFid+  , mergeItemQuant, sharedAllOwned, sharedAllOwnedFid   , getCBag, getActorBag, getBodyActorBag, getActorAssocs   , nearbyFreePoints, whereTo, getCarriedAssocs   , posToActors, posToActor, getItemBody, memActor, getActorBody-  , tryFindHeroK, getLocalTime-  , itemPrice, calmEnough, hpEnough, regenCalmDelta-  , actorInAmbient, actorSkills, dispEnemy, radiusBlind-  , fullAssocs, itemToFull, goesIntoInv, eqpOverfull, storeFromC+  , tryFindHeroK, getLocalTime, itemPrice, regenCalmDelta+  , actorInAmbient, actorSkills, maxActorSkills, dispEnemy+  , fullAssocs, itemToFull, goesIntoInv, eqpOverfull+  , storeFromC, lidFromC, aidFromC   ) where  import Control.Exception.Assert.Sugar@@ -25,7 +25,6 @@  import qualified Game.LambdaHack.Common.Ability as Ability import Game.LambdaHack.Common.Actor-import qualified Game.LambdaHack.Common.Effect as Effect import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest@@ -37,8 +36,9 @@ 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-import Game.LambdaHack.Content.TileKind+import Game.LambdaHack.Content.TileKind (TileKind)  fidActorNotProjAssocs :: FactionId -> State -> [(ActorId, Actor)] fidActorNotProjAssocs fid s =@@ -94,9 +94,9 @@   let iidItem iid = (iid, getItemBody iid s)   in map iidItem $ EM.keys bag -bagAssocsK :: State -> ItemBag -> [(ItemId, (Item, Int))]+bagAssocsK :: State -> ItemBag -> [(ItemId, (Item, ItemQuant))] bagAssocsK s bag =-  let iidItem (iid, k) = (iid, (getItemBody iid s, k))+  let iidItem (iid, kit) = (iid, (getItemBody iid s, kit))   in map iidItem $ EM.assocs bag  -- | Finds an actor at a position on the current level.@@ -133,30 +133,45 @@ -- | Calculate loot's worth for a faction of a given actor. calculateTotal :: Actor -> State -> (ItemBag, Int) calculateTotal body s =-  let bag = sharedAllOwned body s-      items = map (\(iid, k) -> (getItemBody iid s, k)) $ EM.assocs bag+  let bag = sharedAllOwned False body s+      items = map (\(iid, (k, _)) -> (getItemBody iid s, k)) $ EM.assocs bag   in (bag, sum $ map itemPrice items) +mergeItemQuant :: ItemQuant -> ItemQuant -> ItemQuant+mergeItemQuant (k1, it1) (k2, it2) = (k1 + k2, it1 ++ it2)+ sharedInv :: Actor -> State -> ItemBag sharedInv body s =   let bs = fidActorNotProjList (bfid body) s-  in EM.unionsWith (+) $ map binv $ if null bs then [body] else bs+  in EM.unionsWith mergeItemQuant+     $ map binv $ if null bs then [body] else bs  sharedEqp :: Actor -> State -> ItemBag sharedEqp body s =   let bs = fidActorNotProjList (bfid body) s-  in EM.unionsWith (+) $ map beqp $ if null bs then [body] else bs+  in EM.unionsWith mergeItemQuant+     $ map beqp $ if null bs then [body] else bs -sharedAllOwned :: Actor -> State -> ItemBag-sharedAllOwned body s =+sharedOrgan :: Actor -> State -> ItemBag+sharedOrgan body s =+  let bs = fidActorNotProjList (bfid body) s+  in EM.unionsWith mergeItemQuant+     $ map borgan $ if null bs then [body] else bs++sharedAllOwned :: Bool -> Actor -> State -> ItemBag+sharedAllOwned organs body s =   let shaBag = gsha $ sfactionD s EM.! bfid body-  in EM.unionsWith (+) [sharedEqp body s, sharedInv body s, shaBag]+  in EM.unionsWith mergeItemQuant+     $ [sharedEqp body s, sharedInv body s, shaBag]+       ++ [sharedOrgan body s | organs] -sharedAllOwnedFid :: FactionId -> State -> ItemBag-sharedAllOwnedFid fid s =+sharedAllOwnedFid :: Bool -> FactionId -> State -> ItemBag+sharedAllOwnedFid organs fid s =   let shaBag = gsha $ sfactionD s EM.! fid       bs = fidActorNotProjList fid s-  in EM.unionsWith (+) $ map binv bs ++ map beqp bs ++ [shaBag]+  in EM.unionsWith mergeItemQuant+     $ map binv bs ++ map beqp bs ++ [shaBag]+       ++ if organs then map borgan bs else []  -- | Price an item, taking count into consideration. itemPrice :: (Item, Int) -> Int@@ -219,20 +234,27 @@   bagAssocs s $ EM.unionsWith (const) [binv b, beqp b, borgan b]  getCBag :: Container -> State -> ItemBag+{-# INLINE getCBag #-} getCBag c s = case c of-  CFloor lid p -> sdungeon s EM.! lid `atI` p+  CFloor lid p -> EM.findWithDefault EM.empty p+                  $ lfloor (sdungeon s EM.! lid)+  CEmbed lid p -> EM.findWithDefault EM.empty p+                  $ lembed (sdungeon s EM.! lid)   CActor aid cstore -> getActorBag aid cstore s-  CTrunk fid _ _ -> sharedAllOwnedFid fid s+  CTrunk fid _ _ -> sharedAllOwnedFid False fid s  getActorBag :: ActorId -> CStore -> State -> ItemBag+{-# INLINE getActorBag #-} getActorBag aid cstore s =   let b = getActorBody aid s   in getBodyActorBag b cstore s  getBodyActorBag :: Actor -> CStore -> State -> ItemBag+{-# INLINE getBodyActorBag #-} getBodyActorBag b cstore s =   case cstore of-    CGround -> sdungeon s EM.! blid b `atI` bpos b+    CGround -> EM.findWithDefault EM.empty (bpos b)+               $ lfloor (sdungeon s EM.! blid b)     COrgan -> borgan b     CEqp -> beqp b     CInv -> binv b@@ -241,7 +263,7 @@ getActorAssocs :: ActorId -> CStore -> State -> [(ItemId, Item)] getActorAssocs aid cstore s = bagAssocs s $ getActorBag aid cstore s -getActorAssocsK :: ActorId -> CStore -> State -> [(ItemId, (Item, Int))]+getActorAssocsK :: ActorId -> CStore -> State -> [(ItemId, (Item, ItemQuant))] getActorAssocsK aid cstore s = bagAssocsK s $ getActorBag aid cstore s  -- | Checks if the actor is present on the current level.@@ -252,27 +274,17 @@ memActor aid lid s =   maybe False ((== lid) . blid) $ EM.lookup aid $ sactorD s -calmEnough :: Actor -> [ItemFull] -> Bool-calmEnough b activeItems =-  let calmMax = max 1 $ sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems-  in 2 * xM calmMax <= 3 * bcalm b--hpEnough :: Actor -> [ItemFull] -> Bool-hpEnough b activeItems =-  let hpMax = max 1 $ sumSlotNoFilter Effect.EqpSlotAddMaxHP activeItems-  in 2 * xM hpMax <= 3 * bhp b- -- | Get current time from the dungeon data. getLocalTime :: LevelId -> State -> Time getLocalTime lid s = ltime $ sdungeon s EM.! lid  regenCalmDelta :: Actor -> [ItemFull] -> State -> Int64 regenCalmDelta b activeItems s =-  let calmMax = sumSlotNoFilter Effect.EqpSlotAddMaxCalm activeItems+  let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems       calmIncr = oneM  -- normal rate of calm regen       maxDeltaCalm = xM calmMax - bcalm b       -- Worry actor by enemies felt (even if not seen)-      -- on the level within 3 tiles.+      -- on the level within 3 steps.       fact = (EM.! bfid b) . sfactionD $ s       allFoes = actorRegularList (isAtWar fact) (blid b) $ s       isHeard body = not (waitedLastTurn body)@@ -288,8 +300,8 @@       lvl = (EM.! blid b) . sdungeon $ s   in Tile.isLit cotile (lvl `at` bpos b) -actorSkills :: ActorId -> Maybe ActorId -> [ItemFull] -> State -> Ability.Skills-actorSkills aid mleader activeItems s =+actorSkills :: Maybe ActorId -> ActorId -> [ItemFull] -> State -> Ability.Skills+actorSkills mleader aid activeItems s =   let body = getActorBody aid s       fact = (EM.! bfid body) . sfactionD $ s       factionSkills@@ -298,15 +310,24 @@       itemSkills = sumSkills activeItems   in itemSkills `Ability.addSkills` factionSkills +maxActorSkills :: ActorId -> [ItemFull] -> State -> Ability.Skills+maxActorSkills aid activeItems s =+  let body = getActorBody aid s+      fact = (EM.! bfid body) . sfactionD $ s+      factionSkills = Ability.maxSkills Ability.unitSkills+                                        (fskillsOther $ gplayer fact)+      itemSkills = sumSkills activeItems+  in itemSkills `Ability.addSkills` factionSkills+ -- Check whether an actor can displace an enemy. We assume they are adjacent.-dispEnemy :: ActorId -> Maybe ActorId -> ActorId -> [ItemFull] -> State -> Bool-dispEnemy source mleader target activeItems s =+dispEnemy :: ActorId -> ActorId -> [ItemFull] -> State -> Bool+dispEnemy source target activeItems s =   let hasSupport b =         let fact = (EM.! bfid b) . sfactionD $ s             friendlyFid fid = fid == bfid b || isAllied fact fid             sup = actorRegularList friendlyFid (blid b) s         in any (adjacent (bpos b) . bpos) sup-      actorSk = actorSkills target mleader activeItems s+      actorSk = maxActorSkills target activeItems s       sb = getActorBody source s       tb = getActorBody target s   in bproj tb@@ -316,26 +337,20 @@                 && EM.findWithDefault 0 Ability.AbMove actorSk <= 0              || hasSupport sb && hasSupport tb)  -- solo actors are flexible --- | Determine if the sight radius is high enough to deem the actor capable--- of projecting items and similar activities. Otherwise, the actor--- is assumed to use a combination of peripherial vision, hearing, etc.,--- and not the actual focused, long-distance sight sense.-radiusBlind :: Int -> Bool-radiusBlind radius = radius < 4- fullAssocs :: Kind.COps -> DiscoveryKind -> DiscoveryEffect            -> ActorId -> [CStore] -> State            -> [(ItemId, ItemFull)] fullAssocs cops disco discoEffect aid cstores s =   let allAssocs = concatMap (\cstore -> getActorAssocsK aid cstore s) cstores-      iToFull (iid, (item, k)) =-        (iid, itemToFull cops disco discoEffect iid item k)+      iToFull (iid, (item, kit)) =+        (iid, itemToFull cops disco discoEffect iid item kit)   in map iToFull allAssocs -itemToFull :: Kind.COps -> DiscoveryKind -> DiscoveryEffect -> ItemId -> Item -> Int+itemToFull :: Kind.COps -> DiscoveryKind -> DiscoveryEffect -> ItemId -> Item+           -> ItemQuant            -> ItemFull itemToFull Kind.COps{coitem=Kind.Ops{okind}}-           disco discoEffect iid itemBase itemK =+           disco discoEffect iid itemBase (itemK, itemTimer) =   let itemDisco = case EM.lookup (jkindIx itemBase) disco of         Nothing -> Nothing         Just itemKindId -> Just ItemDisco{ itemKindId@@ -347,12 +362,27 @@ goesIntoInv item = isNothing $ strengthEqpSlot item  eqpOverfull :: Actor -> Int -> Bool-eqpOverfull b n = let size = sum $ EM.elems $ beqp b+eqpOverfull b n = let size = sum $ map fst $ EM.elems $ beqp b                   in assert (size <= 10 `blame` (b, n, size))                      $ size + n > 10  storeFromC :: Container -> CStore storeFromC c = case c of   CFloor{} -> CGround+  CEmbed{} -> CGround   CActor _ cstore -> cstore   CTrunk{} -> CGround++-- | Determine the dungeon level of the container. If the item is in a shared+-- stash, the level depends on which actor asks.+lidFromC :: Container -> State -> LevelId+lidFromC (CFloor lid _) _ = lid+lidFromC (CEmbed lid _) _ = lid+lidFromC (CActor aid _) s = blid $ getActorBody aid s+lidFromC (CTrunk _ lid _) _ = lid++aidFromC :: Container -> Maybe ActorId+aidFromC CFloor{} = Nothing+aidFromC CEmbed{} = Nothing+aidFromC (CActor aid _) = Just aid+aidFromC CTrunk{} = Nothing

@@ -10,34 +10,36 @@ import Game.LambdaHack.Common.Faction  data DebugModeCli = DebugModeCli-  { sfont          :: !(Maybe String)+  { sfont           :: !(Maybe String)       -- ^ Font to use for the main game window.-  , smaxFps        :: !(Maybe Int)+  , scolorIsBold    :: !(Maybe Bool)+      -- ^ Whether to use bold attribute for colorful characters.+  , smaxFps         :: !(Maybe Int)       -- ^ Maximal frames per second.       -- This is better low and fixed, to avoid jerkiness and delays       -- that tell the player there are many intelligent enemies on the level.       -- That's better than scaling AI sofistication down based       -- on the FPS setting and machine speed.-  , snoDelay       :: !Bool+  , snoDelay        :: !Bool       -- ^ Don't maintain any requested delays between frames,       -- e.g., for screensaver.-  , snoMore        :: !Bool-      -- ^ Auto-answer all prompts, e.g., for screensaver.-  , snoAnim        :: !(Maybe Bool)+  , sdisableAutoYes :: !Bool+      -- ^ Never auto-answer all prompts, even if under AI control.+  , snoAnim         :: !(Maybe Bool)       -- ^ Don't show any animations.-  , snewGameCli    :: !Bool+  , snewGameCli     :: !Bool       -- ^ Start a new game, overwriting the save file.-  , sbenchmark     :: !Bool+  , sbenchmark      :: !Bool       -- ^ Don't create directories and files and show time stats.-  , sdifficultyCli :: !Int+  , sdifficultyCli  :: !Int       -- ^ The difficulty level for all UI clients.-  , ssavePrefixCli :: !(Maybe String)+  , ssavePrefixCli  :: !(Maybe String)       -- ^ Prefix of the save game file.-  , sfrontendStd   :: !Bool+  , sfrontendStd    :: !Bool       -- ^ Whether to use the stdout/stdin frontend for all clients.-  , sfrontendNull  :: !Bool+  , sfrontendNull   :: !Bool       -- ^ Whether to use void (no input/output) frontend for all clients.-  , sdbgMsgCli     :: !Bool+  , sdbgMsgCli      :: !Bool       -- ^ Show clients' internal debug messages.   }   deriving (Show, Eq, Generic)@@ -47,9 +49,10 @@ defDebugModeCli :: DebugModeCli defDebugModeCli = DebugModeCli   { sfont = Nothing+  , scolorIsBold = Nothing   , smaxFps = Nothing   , snoDelay = False-  , snoMore = False+  , sdisableAutoYes = False   , snoAnim = Nothing   , snewGameCli = False   , sbenchmark = False

@@ -15,12 +15,12 @@  -- | The general type of a particular game content, e.g., item kinds. data ContentDef a = ContentDef-  { getSymbol      :: a -> Char    -- ^ symbol, e.g., to print on the map-  , getName        :: a -> Text    -- ^ name, e.g., to show to the player-  , getFreq        :: a -> Freqs   -- ^ frequency within groups+  { getSymbol      :: a -> Char  -- ^ symbol, e.g., to print on the map+  , getName        :: a -> Text  -- ^ name, e.g., to show to the player+  , getFreq        :: a -> Freqs a  -- ^ frequency within groups   , validateSingle :: a -> [Text]       -- ^ validate a content item and list all offences   , validateAll    :: [a] -> [Text]       -- ^ validate the whole defined content of this type and list all offences-  , content        :: [a]          -- ^ all the defined content of this type+  , content        :: ![a]       -- ^ all the defined content of this type   }

@@ -4,7 +4,7 @@ module Game.LambdaHack.Common.Dice   ( -- * Frequency distribution for casting dice scaled with level depth     Dice, diceConst, diceLevel, diceScale, (|*|)-  , d, z, dl, zl, intToDice+  , d, ds, dl, intToDice   , maxDice, minDice, meanDice, reduceDice     -- * Dice for rolling a pair of integer parameters representing coordinates.   , DiceXY(..), maxDiceXY, minDiceXY, meanDiceXY@@ -35,7 +35,7 @@                      $ map swap $ runFrequency fr  -- Normalized mainly as an optimization, but it also makes many expected--- algeraic laws hold (wrt @Eq@), except for some laws about+-- algebraic laws hold (wrt @Eq@), except for some laws about -- multiplication. We use @liftA2@ instead of @liftM2@, because it's probably -- faster in this case. instance Num SimpleDice where@@ -69,7 +69,8 @@ liftA2AdditiveName name f fra frb =   let frRes = liftA2 f fra frb       nameRes =-        if nameFrequency fra == "0" then nameFrequency frb+        if nameFrequency fra == "0" then+          (if name == "+" then "" else name) <+> nameFrequency frb         else if nameFrequency frb == "0" then nameFrequency fra         else nameFrequency fra <+> name <+> nameFrequency frb   in renameFreq nameRes frRes@@ -80,6 +81,12 @@ zdieSimple :: Int -> SimpleDice zdieSimple n = uniformFreq ("z" <> tshow n) [0..n-1] +dieLevelSimple :: Int -> SimpleDice+dieLevelSimple n = uniformFreq ("ds" <> tshow n) [1..n]++zdieLevelSimple :: Int -> SimpleDice+zdieLevelSimple n = uniformFreq ("zl" <> tshow n) [0..n-1]+ -- | Dice for parameters scaled with current level depth. -- To the result of rolling the first set of dice we add the second, -- scaled in proportion to current depth divided by maximal dungeon depth.@@ -94,10 +101,14 @@  instance Show Dice where   show Dice{..} = T.unpack $-    let scaled = "scaled(" <> nameFrequency diceLevel <> ")"+    let rawScaled = nameFrequency diceLevel+        scaled = if rawScaled == "0" then "" else rawScaled+        signAndScaled = case T.uncons scaled of+          Just ('-', _) -> scaled+          _ -> "+" <+> scaled     in (if nameFrequency diceLevel == "0" then nameFrequency diceConst         else if nameFrequency diceConst == "0" then scaled-        else nameFrequency diceConst <+> "+" <+> scaled)+        else nameFrequency diceConst <+> signAndScaled)        <+> if diceScale == 1 then "" else "|*|" <+> tshow diceScale  instance Hashable Dice@@ -142,14 +153,18 @@ d :: Int -> Dice d n = Dice (dieSimple n) (fromInteger 0) 1 -z :: Int -> Dice-z n = Dice (zdieSimple n) (fromInteger 0) 1+ds :: Int -> Dice+ds n = Dice (fromInteger 0) (dieLevelSimple n) 1  dl :: Int -> Dice-dl n = Dice (fromInteger 0) (dieSimple n) 1+dl = ds -zl :: Int -> Dice-zl n = Dice (fromInteger 0) (zdieSimple n) 1+-- Not exposed to save on documentation.+_z :: Int -> Dice+_z n = Dice (zdieSimple n) (fromInteger 0) 1++_zl :: Int -> Dice+_zl n = Dice (fromInteger 0) (zdieLevelSimple n) 1  intToDice :: Int -> Dice intToDice = fromInteger . fromIntegral

@@ -1,217 +0,0 @@-{-# LANGUAGE DeriveFunctor, DeriveGeneric #-}--- | Effects of content on the game state. No operation in this module--- involves state or monad types.-module Game.LambdaHack.Common.Effect-  ( Effect(..), Aspect(..), ThrowMod(..), Feature(..), EqpSlot(..)-  , effectTrav, aspectTrav-  ) where--import qualified Control.Monad.State as St-import Data.Binary-import Data.Hashable (Hashable)-import Data.Text (Text)-import GHC.Generics (Generic)--import qualified Game.LambdaHack.Common.Ability as Ability-import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Misc-import Game.LambdaHack.Content.ModeKind---- TODO: document each constructor--- | Effects of items. Can be invoked by the item wielder to affect--- another actor or the wielder himself. Many occurences in the same item--- are possible.-data Effect a =-    NoEffect !Text-  | Hurt !Dice.Dice-  | Burn !Int-  | Explode !GroupName    -- ^ explode, producing this group of shrapnel-  | RefillHP !Int-  | RefillCalm !Int-  | Dominate-  | Impress-  | CallFriend !a-  | Summon !Freqs !a-  | CreateItem !a-  | Ascend !Int-  | Escape !Int           -- ^ the Int says if can be placed on last level, etc.-  | Paralyze !a-  | InsertMove !a-  | Teleport !a-  | PolyItem !CStore-  | Identify !CStore-  | SendFlying !ThrowMod-  | PushActor !ThrowMod-  | PullActor !ThrowMod-  | DropBestWeapon-  | DropEqp !Char !Bool   -- ^ symbol @' '@ means all, @True@ means hit on drop-  | ActivateInv !Char     -- ^ symbol @' '@ means all-  | ApplyPerfume-  | OneOf ![Effect a]-  | OnSmash !(Effect a)   -- ^ trigger if item smashed (not applied nor meleed)-  | TimedAspect !Int !(Aspect a)-                          -- ^ enable the aspect for k clips-  deriving (Show, Read, Eq, Ord, Generic, Functor)---- | Aspects of items. Additive (starting at 0) for all items wielded--- by an actor and affect the actor (except @Periodic@ that only affect--- the item and so is not additive).-data Aspect a =-    Periodic !a        -- ^ is activated this many times in 100-  | AddHurtMelee !a    -- ^ percentage damage bonus in melee-  | AddArmorMelee !a   -- ^ percentage armor bonus against melee-  | AddHurtRanged !a   -- ^ percentage damage bonus in ranged-  | AddArmorRanged !a  -- ^ percentage armor bonus against ranged-  | AddMaxHP !a        -- ^ maximal hp-  | AddMaxCalm !a      -- ^ maximal calm-  | AddSpeed !a        -- ^ speed in m/10s-  | AddSkills !Ability.Skills  -- ^ skills in particular abilities-  | AddSight !a        -- ^ FOV radius, where 1 means a single tile-  | AddSmell !a        -- ^ smell radius, where 1 means a single tile-  | AddLight !a        -- ^ light radius, where 1 means a single tile-  deriving (Show, Read, Eq, Ord, Generic, Functor)---- | Parameters modifying a throw. Not additive and don't start at 0.-data ThrowMod = ThrowMod-  { throwVelocity :: !Int  -- ^ fly with this percentage of base throw speed-  , throwLinger   :: !Int  -- ^ fly for this percentage of 2 turns-  }-  deriving (Show, Read, Eq, Ord, Generic)---- | Features of item. Affect only the item in question, not the actor,--- and so not additive in any sense.-data Feature =-    ChangeTo !GroupName     -- ^ change to this group when altered-  | Fragile                 -- ^ break even when not hitting an enemy-  | Durable                 -- ^ don't break even hitting or applying-  | ToThrow !ThrowMod       -- ^ parameters modifying a throw-  | Identified              -- ^ the item starts identified-  | Applicable              -- ^ AI and uI flag: consider applying-  | EqpSlot !EqpSlot !Text  -- ^ AI and uI flag: goes to inventory-  | Precious                -- ^ AI and UI flag: careful, can be precious;-                            --   don't risk identifying by use-  | Tactic !Tactic          -- ^ overrides actor's tactic (TODO)-  deriving (Show, Eq, Ord, Generic)--data EqpSlot =-    EqpSlotPeriodic-  | EqpSlotAddHurtMelee-  | EqpSlotAddArmorMelee-  | EqpSlotAddHurtRanged-  | EqpSlotAddArmorRanged-  | EqpSlotAddMaxHP-  | EqpSlotAddMaxCalm-  | EqpSlotAddSpeed-  | EqpSlotAddSkills-  | EqpSlotAddSight-  | EqpSlotAddSmell-  | EqpSlotAddLight-  | EqpSlotWeapon-  deriving (Show, Eq, Ord, Generic)--instance Hashable a => Hashable (Effect a)--instance Hashable a => Hashable (Aspect a)--instance Hashable ThrowMod--instance Hashable Feature--instance Hashable EqpSlot--instance Binary a => Binary (Effect a)--instance Binary a => Binary (Aspect a)--instance Binary ThrowMod--instance Binary Feature--instance Binary EqpSlot---- TODO: Traversable?--- | Transform an effect using a stateful function.-effectTrav :: Effect a -> (a -> St.State s b) -> St.State s (Effect b)-effectTrav (NoEffect t) _ = return $! NoEffect t-effectTrav (RefillHP p) _ = return $! RefillHP p-effectTrav (Hurt dice) _ = return $! Hurt dice-effectTrav (RefillCalm p) _ = return $! RefillCalm p-effectTrav Dominate _ = return Dominate-effectTrav Impress _ = return Impress-effectTrav (CallFriend a) f = do-  b <- f a-  return $! CallFriend b-effectTrav (Summon freqs a) f = do-  b <- f a-  return $! Summon freqs b-effectTrav (CreateItem a) f = do-  b <- f a-  return $! CreateItem b-effectTrav ApplyPerfume _ = return ApplyPerfume-effectTrav (Burn p) _ = return $! Burn p-effectTrav (Ascend p) _ = return $! Ascend p-effectTrav (Escape p) _ = return $! Escape p-effectTrav (Paralyze a) f = do-  b <- f a-  return $! Paralyze b-effectTrav (InsertMove a) f = do-  b <- f a-  return $! InsertMove b-effectTrav DropBestWeapon _ = return DropBestWeapon-effectTrav (DropEqp symbol hit) _ = return $! DropEqp symbol hit-effectTrav (SendFlying tmod) _ = return $! SendFlying tmod-effectTrav (PushActor tmod) _ = return $! PushActor tmod-effectTrav (PullActor tmod) _ = return $! PullActor tmod-effectTrav (Teleport a) f = do-  b <- f a-  return $! Teleport b-effectTrav (PolyItem cstore) _ = return $! PolyItem cstore-effectTrav (Identify cstore) _ = return $! Identify cstore-effectTrav (ActivateInv symbol) _ = return $! ActivateInv symbol-effectTrav (OneOf la) f = do-  lb <- mapM (\a -> effectTrav a f) la-  return $! OneOf lb-effectTrav (OnSmash effa) f = do-  effb <- effectTrav effa f-  return $! OnSmash effb-effectTrav (Explode t) _ = return $! Explode t-effectTrav (TimedAspect k asp) f = do-  asp2 <- aspectTrav asp f-  return $! TimedAspect k asp2---- | Transform an aspect using a stateful function.-aspectTrav :: Aspect a -> (a -> St.State s b) -> St.State s (Aspect b)-aspectTrav (Periodic a) f = do-  b <- f a-  return $! Periodic b-aspectTrav (AddMaxHP a) f = do-  b <- f a-  return $! AddMaxHP b-aspectTrav (AddMaxCalm a) f = do-  b <- f a-  return $! AddMaxCalm b-aspectTrav (AddSpeed a) f = do-  b <- f a-  return $! AddSpeed b-aspectTrav (AddSkills as) _ = return $! AddSkills as-aspectTrav (AddHurtMelee a) f = do-  b <- f a-  return $! AddHurtMelee b-aspectTrav (AddHurtRanged a) f = do-  b <- f a-  return $! AddHurtRanged b-aspectTrav (AddArmorMelee a) f = do-  b <- f a-  return $! AddArmorMelee b-aspectTrav (AddArmorRanged a) f = do-  b <- f a-  return $! AddArmorRanged b-aspectTrav (AddSight a) f = do-  b <- f a-  return $! AddSight b-aspectTrav (AddSmell a) f = do-  b <- f a-  return $! AddSmell b-aspectTrav (AddLight a) f = do-  b <- f a-  return $! AddLight b

@@ -12,81 +12,109 @@ import qualified Data.Text as T import qualified NLP.Miniutter.English as MU --- import Game.LambdaHack.Common.Actor (ppCStore)+import Game.LambdaHack.Common.Actor import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Effect+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Time+import Game.LambdaHack.Content.ItemKind  -- | Suffix to append to a basic content name if the content causes the effect.-effectToSuff :: (Show a, Ord a, Num a)-             => Effect a -> (a -> Text) -> (a -> Maybe Int) -> Text-effectToSuff effect f g =-  case ( St.evalState (effectTrav effect $ return . f) ()-       , St.evalState (effectTrav effect $ return . g) () ) of-    (NoEffect t, _) -> t-    (RefillHP p, _) | p > 0 -> "of healing" <+> wrapInParens (affixBonus p)-    (RefillHP 0, _) -> assert `failure` effect-    (RefillHP p, _) -> "of wounding" <+> wrapInParens (affixBonus p)-    (Hurt dice, _) -> wrapInParens (tshow dice)-    (RefillCalm p, _) | p > 0 -> "of soothing" <+> wrapInParens (affixBonus p)-    (RefillCalm 0, _) -> assert `failure` effect-    (RefillCalm p, _) -> "of dismaying" <+> wrapInParens (affixBonus p)-    (Dominate, _) -> "of domination"-    (Impress, _) -> "of impression"-    (_, CallFriend (Just 1)) -> "of aid calling"-    (CallFriend t, _) -> "of aid calling"-                         <+> wrapInParens (dropPlus t <+> "friends")-    (_, Summon _freqs (Just 1)) -> "of summoning"  -- TODO-    (Summon _freqs t, _) -> "of summoning"-                            <+> wrapInParens (dropPlus t <+> "actors")-    (_, CreateItem (Just 1)) -> "of uncovering"-    (CreateItem t, _) -> "of uncovering"-                         <+> wrapInParens (dropPlus t <+> "items")-    (ApplyPerfume, _) -> "of smell removal"-    (Burn p, _) | p <= 0 -> assert `failure` effect-    (Burn p, _) -> wrapInParens (makePhrase [MU.CarWs p "burn"])-    (Ascend 1, _) -> "of ascending"-    (Ascend p, _) | p > 0 ->-      "of ascending" <+> wrapInParens (tshow p <+> "levels")-    (Ascend 0, _) -> assert `failure` effect-    (Ascend (-1), _) -> "of descending"-    (Ascend p, _) ->-      "of descending" <+> wrapInParens (tshow (-p) <+> "levels")-    (Escape{}, _) -> "of escaping"-    (_, Paralyze Nothing) -> "of paralysis (? clips)"-    (_, Paralyze (Just p)) ->-      let clipInTurn = timeTurn `timeFit` timeClip-          seconds = 0.5 * fromIntegral p / fromIntegral clipInTurn :: Double-      in "of paralysis" <+> wrapInParens (tshow seconds <> "s")-    (_, InsertMove Nothing) ->-      "of speed surge (? moves)"-    (_, InsertMove (Just p)) ->-      "of speed surge" <+> wrapInParens (makePhrase [MU.CarWs p "move"])-    (DropBestWeapon, _) -> "of disarming"-    (DropEqp ' ' False, _) -> "of equipment drop"-    (DropEqp symbol False, _) -> "of drop '" <> T.singleton symbol <> "'"-    (DropEqp ' ' True, _) -> "of equipment smash"-    (DropEqp symbol True, _) -> "of smash '" <> T.singleton symbol <> "'"-    (SendFlying tmod, _) -> "of impact" <+> tmodToSuff "" tmod-    (PushActor tmod, _) -> "of pushing" <+> tmodToSuff "" tmod-    (PullActor tmod, _) -> "of pulling" <+> tmodToSuff "" tmod-    (_, Teleport (Just p)) | p <= 1  -> assert `failure` effect-    (Teleport t, Teleport (Just p)) | p <= 9  ->-      "of blinking" <+> wrapInParens (dropPlus t <+> "steps")-    (Teleport t, _)->-      "of teleport" <+> wrapInParens (dropPlus t <+> "steps")-    (PolyItem _cstore, _) -> "of repurpose"  -- <+> ppCStore cstore-    (Identify _cstore, _) -> "of identify"  -- <+> ppCStore cstore-    (ActivateInv ' ', _) -> "of inventory burst"-    (ActivateInv symbol, _) -> "of burst '" <> T.singleton symbol <> "'"-    (Explode _, _) -> "of explosion"  -- TODO: first word + explosion? nothing?-    (OneOf l, _) ->+--+-- We show absolute time in seconds, not @moves@, because actors can have+-- different speeds (and actions can potentially take different time intervals).+-- We call the time taken by one player move, when walking, a @move@.+-- @Turn@ and @clip@ are used mostly internally, the former as an absolute+-- time unit.+-- We show distances in @steps@, because one step, from a tile to another+-- tile, is always 1 meter. We don't call steps @tiles@, reserving+-- that term for the context of terrain kinds or units of area.+effectToSuff :: Effect -> Text+effectToSuff effect =+  case effect of+    NoEffect t -> t+    Hurt dice -> wrapInParens (tshow dice)+    Burn p | p <= 0 -> assert `failure` effect+    Burn p -> wrapInParens (makePhrase [MU.CarWs p "burn"])+    Explode t -> "of" <+> tshow t <+> "explosion"+    RefillHP p | p > 0 ->+      "of limited healing" <+> wrapInParens (affixBonus p)+    RefillHP 0 -> assert `failure` effect+    RefillHP p ->+      "of limited wounding" <+> wrapInParens (affixBonus p)+    OverfillHP p | p > 0 -> "of healing" <+> wrapInParens (affixBonus p)+    OverfillHP 0 -> assert `failure` effect+    OverfillHP p -> "of wounding" <+> wrapInParens (affixBonus p)+    RefillCalm p | p > 0 ->+      "of limited soothing" <+> wrapInParens (affixBonus p)+    RefillCalm 0 -> assert `failure` effect+    RefillCalm p ->+      "of limited dismaying" <+> wrapInParens (affixBonus p)+    OverfillCalm p | p > 0 -> "of soothing" <+> wrapInParens (affixBonus p)+    OverfillCalm 0 -> assert `failure` effect+    OverfillCalm p -> "of dismaying" <+> wrapInParens (affixBonus p)+    Dominate -> "of domination"+    Impress -> "of impression"+    CallFriend 1 -> "of aid calling"+    CallFriend dice -> "of aid calling"+                       <+> wrapInParens (tshow dice <+> "friends")+    Summon _freqs 1 -> "of summoning"  -- TODO+    Summon _freqs dice -> "of summoning"+                          <+> wrapInParens (tshow dice <+> "actors")+    ApplyPerfume -> "of smell removal"+    Ascend 1 -> "of ascending"+    Ascend p | p > 0 ->+      "of ascending for" <+> tshow p <+> "levels"+    Ascend 0 -> assert `failure` effect+    Ascend (-1) -> "of descending"+    Ascend p ->+      "of descending for" <+> tshow (-p) <+> "levels"+    Escape{} -> "of escaping"+    Paralyze dice ->+      let time = case Dice.reduceDice dice of+            Nothing -> tshow dice+            Just p ->+              let clipInTurn = timeTurn `timeFit` timeClip+                  seconds =+                    0.5 * fromIntegral p / fromIntegral clipInTurn :: Double+              in tshow seconds <> "s"+      in "of paralysis for" <+> time+    InsertMove dice ->+      let moves = case Dice.reduceDice dice of+            Nothing -> tshow dice <+> "moves"+            Just p -> makePhrase [MU.CarWs p "move"]+      in "of speed surge for" <+> moves+    Teleport dice | dice <= 0 ->+      assert `failure` effect+    Teleport dice | dice <= 9 ->+      "of blinking" <+> wrapInParens (tshow dice <+> "steps")+    Teleport dice ->+      "of teleport" <+> wrapInParens (tshow dice <+> "steps")+    CreateItem COrgan grp tim ->+      let stime = if tim == TimerNone then "" else "for" <+> tshow tim <> ":"+      in "(keep" <+> stime <+> tshow grp <> ")"+    CreateItem _ grp _ ->+      let object = if grp == "useful" then "" else tshow grp+      in "of" <+> object <+> "uncovering"+    DropItem COrgan grp True -> "of nullify" <+> tshow grp+    DropItem _ grp hit ->+      let grpText = tshow grp+          hitText = if hit then "smash" else "drop"+      in "of" <+> hitText <+> grpText  -- TMI: <+> ppCStore store+    PolyItem store -> "of repurpose" <+> ppCStore store+    Identify store -> "of identify starting" <+> ppCStore store+    SendFlying tmod -> "of impact" <+> tmodToSuff "" tmod+    PushActor tmod -> "of pushing" <+> tmodToSuff "" tmod+    PullActor tmod -> "of pulling" <+> tmodToSuff "" tmod+    DropBestWeapon -> "of disarming"+    ActivateInv ' ' -> "of inventory burst"+    ActivateInv symbol -> "of burst '" <> T.singleton symbol <> "'"+    OneOf l ->       let subject = if length l <= 5 then "marvel" else "wonder"       in makePhrase ["of", MU.CardinalWs (length l) subject]-    (OnSmash _, _) -> ""  -- conditional effect, TMI-    (TimedAspect _ aspect, _) -> "keep (" <> rawAspectToSuff aspect <> ")"-    (effectF, effectG) -> assert `failure` (effect, effectF, effectG)+    OnSmash _ -> ""  -- printed inside a separate section+    Recharging _ -> ""  -- printed inside Periodic or Timeout+    Temporary _ -> ""  tmodToSuff :: Text -> ThrowMod -> Text tmodToSuff verb ThrowMod{..} =@@ -104,11 +132,12 @@ rawAspectToSuff :: Aspect Text -> Text rawAspectToSuff aspect =   case aspect of-    Periodic t -> wrapInParens $ dropPlus t <+> "in 100"+    Periodic{} -> ""  -- printed specially+    Timeout{}  -> ""  -- printed specially     AddMaxHP t -> wrapInParens $ t <+> "HP"     AddMaxCalm t -> wrapInParens $ t <+> "Calm"     AddSpeed t -> wrapInParens $ t <+> "speed"-    AddSkills p -> wrapInParens $ "+" <+> tshow (EM.toList p)+    AddSkills p -> wrapInParens $ "+" <+> T.pack (show $ EM.toList p)     AddHurtMelee t -> wrapInParens $ t <> "% melee"     AddHurtRanged  t -> wrapInParens $ t <> "% ranged"     AddArmorMelee t -> "[" <> t <> "%]"@@ -120,21 +149,17 @@ featureToSuff :: Feature -> Text featureToSuff feat =   case feat of-    ChangeTo t -> wrapInChevrons $ "changes to" <+> tshow t-    Fragile -> wrapInChevrons $ "fragile"-    Durable -> wrapInChevrons $ "durable"+    Fragile -> wrapInChevrons "fragile"+    Durable -> wrapInChevrons "durable"     ToThrow tmod -> wrapInChevrons $ tmodToSuff "flies" tmod     Identified -> ""     Applicable -> ""     EqpSlot{} -> ""-    Precious -> ""+    Precious -> wrapInChevrons "precious"     Tactic tactics -> "overrides tactics to" <+> tshow tactics -dropPlus :: Text -> Text-dropPlus = T.dropWhile (`elem` ['+', '-'])--effectToSuffix :: Effect Int -> Text-effectToSuffix effect = effectToSuff effect affixBonus Just+effectToSuffix :: Effect -> Text+effectToSuffix effect = effectToSuff effect  aspectToSuffix :: Aspect Int -> Text aspectToSuffix aspect = aspectToSuff aspect affixBonus@@ -156,8 +181,8 @@ affixDice :: Dice.Dice -> Text affixDice d = maybe "+?" affixBonus $ Dice.reduceDice d -kindEffectToSuffix :: Effect Dice.Dice -> Text-kindEffectToSuffix effect = effectToSuff effect affixDice Dice.reduceDice+kindEffectToSuffix :: Effect -> Text+kindEffectToSuffix = effectToSuffix  kindAspectToSuffix :: Aspect Dice.Dice -> Text kindAspectToSuffix aspect = aspectToSuff aspect affixDice

@@ -26,7 +26,7 @@ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Vector-import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.ItemKind (ItemKind) import Game.LambdaHack.Content.ModeKind  -- | All factions in the game, indexed by faction identifier.@@ -35,7 +35,7 @@ data Faction = Faction   { gname    :: !Text            -- ^ individual name   , gcolor   :: !Color.Color     -- ^ color of actors or their frames-  , gplayer  :: !Player          -- ^ the player spec for this faction+  , gplayer  :: !(Player Int)    -- ^ the player spec for this faction   , gdipl    :: !Dipl            -- ^ diplomatic mode   , gquit    :: !(Maybe Status)  -- ^ cause of game end/exit   , gleader  :: !(Maybe (ActorId, Maybe Target))@@ -67,9 +67,10 @@  -- | Current game status. data Status = Status-  { stOutcome :: !Outcome            -- ^ current game outcome-  , stDepth   :: !Int                -- ^ depth of the final encounter-  , stNewGame :: !(Maybe GroupName)  -- ^ new game group to start, if any+  { stOutcome :: !Outcome  -- ^ current game outcome+  , stDepth   :: !Int      -- ^ depth of the final encounter+  , stNewGame :: !(Maybe (GroupName ModeKind))+                           -- ^ new game group to start, if any   }   deriving (Show, Eq, Ord) @@ -131,7 +132,7 @@                           LeaderAI AutoLeader{..} -> (autoDungeon, autoLevel)                           LeaderUI AutoLeader{..} -> (autoDungeon, autoLevel) -automatePlayer :: Bool -> Player -> Player+automatePlayer :: Bool -> Player a -> Player a automatePlayer st pl =   let autoLeader False Player{fleaderMode=LeaderAI auto} = LeaderUI auto       autoLeader True Player{fleaderMode=LeaderUI auto} = LeaderAI auto

@@ -1,39 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--- | Terrain tile features.-module Game.LambdaHack.Common.Feature-  ( Feature(..)-  ) where--import Data.Binary-import Data.Hashable (Hashable)-import GHC.Generics (Generic)--import qualified Game.LambdaHack.Common.Effect as Effect-import Game.LambdaHack.Common.Misc---- | All possible terrain tile features.-data Feature =-    Cause !(Effect.Effect Int)  -- ^ causes the effect when triggered-  | OpenTo !GroupName    -- ^ goes from a closed to an open tile when altered-  | CloseTo !GroupName   -- ^ goes from an open to a closed tile when altered-  | ChangeTo !GroupName  -- ^ alters tile, but does not change walkability-  | HideAs !GroupName    -- ^ when hidden, looks as a tile of the group-  | RevealAs !GroupName  -- ^ if secret, can be revealed to belong to the group--  | Walkable             -- ^ actors can walk through-  | Clear                -- ^ actors can see through-  | Dark                 -- ^ is not lit with an ambient shine-  | Suspect              -- ^ may not be what it seems (clients only)-  | Aura !(Effect.Effect Int)  -- ^ sustains the effect continuously, TODO-  | Impenetrable         -- ^ can never be excavated nor seen through--  | OftenItem            -- ^ initial items often generated there-  | OftenActor           -- ^ initial actors and stairs often generated there-  | NoItem               -- ^ no items ever generated there-  | NoActor              -- ^ no actors nor stairs ever generated there-  | Trail                -- ^ used for visible trails throughout the level-  deriving (Show, Read, Eq, Ord, Generic)--instance Binary Feature--instance Hashable Feature

@@ -73,13 +73,24 @@                  -> IO () tryCopyDataFiles dataDir pathsDataFile files =   let cpFile (fin, fout) = do-        pathsDataIn <- pathsDataFile fin-        bIn <- doesFileExist pathsDataIn-        let pathsDataOut = dataDir </> fout-        bOut <- doesFileExist pathsDataOut-        when (not bOut && bIn) $-          Ex.handle (\(_ :: Ex.IOException) -> return ())-                    (copyFile pathsDataIn pathsDataOut)+        mpathsDataIn <- do+          pathsDataIn1 <- pathsDataFile fin+          bIn1 <- doesFileExist pathsDataIn1+          if bIn1 then return $ Just pathsDataIn1+          else do+            currentDir <- getCurrentDirectory+            let pathsDataIn2 = currentDir </> fin+            bIn2 <- doesFileExist pathsDataIn2+            if bIn2 then return $ Just pathsDataIn2+            else return Nothing+        case mpathsDataIn of+          Nothing -> return ()+          Just pathsDataIn -> do+            let pathsDataOut = dataDir </> fout+            bOut <- doesFileExist pathsDataOut+            when (not bOut) $+              Ex.handle (\(_ :: Ex.IOException) -> return ())+                        (copyFile pathsDataIn pathsDataOut)   in mapM_ cpFile files  -- | Personal data directory for the game. Depends on the OS and the game,

@@ -4,7 +4,7 @@   ( -- * The @Flavour@ type     Flavour   , -- * Constructors-    zipPlain, zipFancy, stdFlav+    zipPlain, zipFancy, stdFlav, zipLiquid   , -- * Accessors     flavourToColor, flavourToName     -- * Assorted@@ -18,11 +18,18 @@  import Game.LambdaHack.Common.Color +data FancyName = Plain | Fancy | Liquid+  deriving (Show, Eq, Ord, Generic)++instance Hashable FancyName++instance Binary FancyName+ -- TODO: add more variety, as the number of items increases -- | The type of item flavours. data Flavour = Flavour-  { fancyName :: !Bool   -- ^ should the colour description be fancy or plain-  , baseColor :: !Color  -- ^ the colour of the flavour+  { fancyName :: !FancyName  -- ^ how fancy should the colour description be+  , baseColor :: !Color      -- ^ the colour of the flavour   }   deriving (Show, Eq, Ord, Generic) @@ -31,13 +38,14 @@ instance Binary Flavour  -- | Turn a colour set into a flavour set.-zipPlain, zipFancy :: [Color] -> [Flavour]-zipPlain = map (Flavour False)-zipFancy = map (Flavour True)+zipPlain, zipFancy, zipLiquid :: [Color] -> [Flavour]+zipPlain = map (Flavour Plain)+zipFancy = map (Flavour Fancy)+zipLiquid = map (Flavour Liquid)  -- | The standard full set of flavours. stdFlav :: [Flavour]-stdFlav = zipPlain stdCol ++ zipFancy stdCol+stdFlav = zipPlain stdCol ++ zipFancy stdCol ++ zipLiquid stdCol  -- | Get the underlying base colour of a flavour. flavourToColor :: Flavour -> Color@@ -45,10 +53,11 @@  -- | Construct the full name of a flavour. flavourToName :: Flavour -> Text-flavourToName Flavour{..} | fancyName = colorToFancyName baseColor-flavourToName Flavour{..}             = colorToPlainName baseColor+flavourToName Flavour{fancyName=Plain, ..} = colorToPlainName baseColor+flavourToName Flavour{fancyName=Fancy, ..} = colorToFancyName baseColor+flavourToName Flavour{fancyName=Liquid, ..} = colorToLiquidName baseColor --- | Human-readable names, for item colors. The simple set.+-- | Human-readable names for item colors. The plain set. colorToPlainName :: Color -> Text colorToPlainName Black     = "black" colorToPlainName Red       = "red"@@ -67,7 +76,7 @@ colorToPlainName BrCyan    = "aquamarine" colorToPlainName BrWhite   = "white" --- | Human-readable names, for item colors. The fancy set.+-- | Human-readable names for item colors. The fancy set. colorToFancyName :: Color -> Text colorToFancyName Black     = "smoky-black" colorToFancyName Red       = "apple-red"@@ -85,6 +94,25 @@ colorToFancyName BrMagenta = "magenta" colorToFancyName BrCyan    = "turquoise" colorToFancyName BrWhite   = "ghost-white"++-- | Human-readable names for item colors. The liquid set.+colorToLiquidName :: Color -> Text+colorToLiquidName Black     = "tarry"+colorToLiquidName Red       = "bloody"+colorToLiquidName Green     = "moldy"+colorToLiquidName Brown     = "muddy"+colorToLiquidName Blue      = "oily"+colorToLiquidName Magenta   = "swirling"+colorToLiquidName Cyan      = "bubbling"+colorToLiquidName White     = "cloudy"+colorToLiquidName BrBlack   = "pitchy"+colorToLiquidName BrRed     = "red-speckled"+colorToLiquidName BrGreen   = "sappy"+colorToLiquidName BrYellow  = "gold"+colorToLiquidName BrBlue    = "blue-speckled"+colorToLiquidName BrMagenta = "hazy"+colorToLiquidName BrCyan    = "misty"+colorToLiquidName BrWhite   = "shining"  -- | Simple names for team colors (bright colours preferred). colorToTeamName :: Color -> Text

@@ -35,39 +35,39 @@ -- the expected equalities, unless they do some kind of normalization -- (see 'Dice'). data Frequency a = Frequency-  { nameFrequency :: Text         -- ^ short description for debug, etc.;+  { runFrequency  :: ![(Int, a)]  -- ^ give acces to raw frequency values+  , nameFrequency :: Text         -- ^ short description for debug, etc.;                                   --   keep it lazy, because it's rarely used-  , runFrequency  :: ![(Int, a)]  -- ^ give acces to raw frequency values   }   deriving (Show, Read, Eq, Ord, Foldable, Traversable, Generic)  instance Monad Frequency where   {-# INLINE return #-}-  return x = Frequency "return" [(1, x)]-  Frequency name xs >>= f =-    Frequency ("bind (" <> name <> ")")-              [ (p * q, y) | (p, x) <- xs+  return x = Frequency [(1, x)] "return"+  Frequency xs name >>= f =+    Frequency [ (p * q, y) | (p, x) <- xs                            , (q, y) <- runFrequency (f x) ]+              ("bind (" <> name <> ")")  instance Functor Frequency where-  fmap f (Frequency name xs) = Frequency name (map (second f) xs)+  fmap f (Frequency xs name) = Frequency (map (second f) xs) name  instance Applicative Frequency where   pure  = return-  Frequency fname fs <*> Frequency yname ys =-    Frequency ("(" <> fname <> ") <*> (" <> yname <> ")")-              [ (p * q, f y) | (p, f) <- fs+  Frequency fs fname <*> Frequency ys yname =+    Frequency [ (p * q, f y) | (p, f) <- fs                              , (q, y) <- ys ]+              ("(" <> fname <> ") <*> (" <> yname <> ")")  instance MonadPlus Frequency where-  mplus (Frequency xname xs) (Frequency yname ys) =+  mplus (Frequency xs xname) (Frequency ys yname) =     let name = case (xs, ys) of           ([], []) -> "[]"           ([], _ ) -> yname           (_,  []) -> xname           _ -> "(" <> xname <> ") ++ (" <> yname <> ")"-    in Frequency name (xs ++ ys)-  mzero = Frequency "[]" []+    in Frequency (xs ++ ys) name+  mzero = Frequency [] "[]"  instance Alternative Frequency where   (<|>) = mplus@@ -79,19 +79,19 @@  -- | Uniform discrete frequency distribution. uniformFreq :: Text -> [a] -> Frequency a-uniformFreq name = Frequency name . map (\x -> (1, x))+uniformFreq name l = Frequency (map (\x -> (1, x)) l) name  -- | Takes a name and a list of frequencies and items -- into the frequency distribution. toFreq :: Text -> [(Int, a)] -> Frequency a-toFreq = Frequency+toFreq = flip Frequency  -- | Scale frequecy distribution, multiplying it -- by a positive integer constant. scaleFreq :: Show a => Int -> Frequency a -> Frequency a-scaleFreq n (Frequency name xs) =+scaleFreq n (Frequency xs name) =   assert (n > 0 `blame` "non-positive frequency scale" `twith` (name, n, xs)) $-  Frequency name (map (first (* n)) xs)+  Frequency (map (first (* n)) xs) name  -- | Change the description of the frequency. renameFreq :: Text -> Frequency a -> Frequency a@@ -99,27 +99,27 @@  -- | Set frequency of an element. setFreq :: Eq a => Frequency a -> a -> Int -> Frequency a-setFreq (Frequency name xs) x n =+setFreq (Frequency xs name) x n =   let f (_, y) | y == x = (n, x)       f my = my-  in Frequency name $ map f xs+  in Frequency (map f xs) name  -- | Test if the frequency distribution is empty. nullFreq :: Frequency a -> Bool-nullFreq (Frequency _ fs) = all (<= 0) $ map fst fs+nullFreq (Frequency fs _) = all (<= 0) $ map fst fs  maxFreq :: (Show a, Ord a) => Frequency a -> a-maxFreq fr@(Frequency _ xs) = case filter ((> 0 ) . fst) xs of+maxFreq fr@(Frequency xs _) = case filter ((> 0 ) . fst) xs of   [] -> assert `failure` fr   ys -> maximum $ map snd ys  minFreq :: (Show a, Ord a) => Frequency a -> a-minFreq fr@(Frequency _ xs) = case filter ((> 0 ) . fst) xs of+minFreq fr@(Frequency xs _) = case filter ((> 0 ) . fst) xs of   [] -> assert `failure` fr   ys -> minimum $ map snd ys  meanFreq :: (Show a, Integral a) => Frequency a -> Rational-meanFreq fr@(Frequency _ xs) = case filter ((> 0 ) . fst) xs of+meanFreq fr@(Frequency xs _) = case filter ((> 0 ) . fst) xs of   [] -> assert `failure` fr   ys -> let sumP = sum $ map fst ys             sumX = sum [ fromIntegral p * x | (p, x) <- ys ]

@@ -24,7 +24,7 @@ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg import Game.LambdaHack.Common.Time-import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Content.ItemKind (ItemKind)  -- | A single score record. Records are ordered in the highscore table, -- from the best to the worst, in lexicographic ordering wrt the fields below.

@@ -8,7 +8,7 @@   , ItemKindIx, DiscoveryKind, ItemSeed, ItemAspectEffect(..), DiscoveryEffect   , ItemFull(..), ItemDisco(..), itemNoDisco, itemNoAE     -- * Inventory management types-  , ItemBag, ItemDict, ItemKnown+  , ItemTimer, ItemQuant, ItemBag, ItemDict, ItemKnown   ) where  import qualified Control.Monad.State as St@@ -20,11 +20,11 @@ import GHC.Generics (Generic) import System.Random (mkStdGen) -import Game.LambdaHack.Common.Effect import Game.LambdaHack.Common.Flavour import qualified Game.LambdaHack.Common.Kind as Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Random+import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind  -- | A unique identifier of an item in the dungeon.@@ -48,7 +48,7 @@  data ItemAspectEffect = ItemAspectEffect   { jaspects :: ![Aspect Int]  -- ^ the aspects of the item-  , jeffects :: ![Effect Int]  -- ^ the effects when activated+  , jeffects :: ![Effect]      -- ^ the effects when activated   }   deriving (Show, Eq, Generic) @@ -61,22 +61,23 @@ type DiscoveryEffect = EM.EnumMap ItemId ItemAspectEffect  data ItemDisco = ItemDisco-  { itemKindId :: Kind.Id ItemKind-  , itemKind   :: ItemKind-  , itemAE     :: Maybe ItemAspectEffect+  { itemKindId :: !(Kind.Id ItemKind)+  , itemKind   :: !ItemKind+  , itemAE     :: !(Maybe ItemAspectEffect)   }   deriving Show  data ItemFull = ItemFull   { itemBase  :: !Item   , itemK     :: !Int+  , itemTimer :: !ItemTimer   , itemDisco :: !(Maybe ItemDisco)   }   deriving Show  itemNoDisco :: (Item, Int) -> ItemFull itemNoDisco (itemBase, itemK) =-  ItemFull {itemBase, itemK, itemDisco=Nothing}+  ItemFull {itemBase, itemK, itemTimer = [], itemDisco=Nothing}  itemNoAE :: ItemFull -> ItemFull itemNoAE itemFull@ItemFull{..} =@@ -107,14 +108,16 @@                      -> ItemAspectEffect seedToAspectsEffects (ItemSeed itemSeed) kind ldepth totalDepth =   let castD = castDice ldepth totalDepth-      rollAE = do-        aspects <- mapM (flip aspectTrav castD) (iaspects kind)-        effects <- mapM (flip effectTrav castD) (ieffects kind)-        return (aspects, effects)-      (jaspects, jeffects) = St.evalState rollAE (mkStdGen itemSeed)+      rollA = mapM (flip aspectTrav castD) (iaspects kind)+      jaspects = St.evalState rollA (mkStdGen itemSeed)+      jeffects = ieffects kind   in ItemAspectEffect{..} -type ItemBag = EM.EnumMap ItemId Int+type ItemTimer = [Time]++type ItemQuant = (Int, ItemTimer)++type ItemBag = EM.EnumMap ItemId ItemQuant  -- | All items in the dungeon (including in actor inventories), -- indexed by item identifier.

@@ -10,90 +10,149 @@ import qualified Data.Text as T import qualified NLP.Miniutter.English as MU +import Game.LambdaHack.Common.ActorState import qualified Game.LambdaHack.Common.Color as Color-import qualified Game.LambdaHack.Common.Effect as Effect+import qualified Game.LambdaHack.Common.Dice as Dice import Game.LambdaHack.Common.EffectDescription import Game.LambdaHack.Common.Flavour import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.ItemStrongest import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Msg-import Game.LambdaHack.Content.ItemKind+import Game.LambdaHack.Common.Time+import qualified Game.LambdaHack.Content.ItemKind as IK +-- TODO: remove _lid if still unused after some time -- | The part of speech describing the item parameterized by the number -- of effects/aspects to show..-partItemN :: Bool -> Int -> CStore -> ItemFull -> (MU.Part, MU.Part)-partItemN fullInfo n cstore itemFull =+partItemN :: Bool -> Int -> Container -> LevelId -> Time -> ItemFull+          -> (MU.Part, MU.Part)+partItemN fullInfo n c _lid localTime itemFull =   let genericName = jname $ itemBase itemFull   in case itemDisco itemFull of     Nothing ->       let flav = flavourToName $ jflavour $ itemBase itemFull       in (MU.Text $ flav <+> genericName, "")     Just _ ->-      let effTs = filter (not . T.null) $ textAllAE fullInfo cstore itemFull-          ts = take n effTs ++ if length effTs > n then ["(...)"] else []+      let effTs = filter (not . T.null) $ textAllAE fullInfo c itemFull+          it1 = case strengthFromEqpSlot IK.EqpSlotTimeout itemFull of+            Nothing -> []+            Just timeout ->+              let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout+                  f startT = timeShift startT timeoutTurns > localTime+              in filter f (itemTimer itemFull)+          len = length it1+          timer = if len == 0+                  then ""+                  else if itemK itemFull == 1 && len == 1+                  then "(charging)"+                  else "(" <> tshow len <+> "charging" <> ")"+          ts = take n effTs+               ++ (if length effTs > n then ["(...)"] else [])+               ++ [timer]       in (MU.Text genericName, MU.Phrase $ map MU.Text ts)  -- | The part of speech describing the item.-partItem :: CStore -> ItemFull -> (MU.Part, MU.Part)+partItem :: Container -> LevelId -> Time -> ItemFull -> (MU.Part, MU.Part) partItem = partItemN False 4 -textAllAE :: Bool -> CStore -> ItemFull -> [Text]-textAllAE fullInfo cstore ItemFull{itemBase, itemDisco} =+textAllAE :: Bool -> Container -> ItemFull -> [Text]+textAllAE fullInfo c ItemFull{itemBase, itemDisco} =   let features | fullInfo = map featureToSuff $ sort $ jfeature itemBase                | otherwise = []   in case itemDisco of     Nothing -> features     Just ItemDisco{itemKind, itemAE} ->-      let periodicAspect :: Effect.Aspect a -> Bool-          periodicAspect (Effect.Periodic _) = True+      let periodicAspect :: IK.Aspect a -> Bool+          periodicAspect IK.Periodic = True           periodicAspect _ = False-          hurtEffect :: Effect.Effect a -> Bool-          hurtEffect (Effect.Hurt _) = True+          timeoutAspect :: IK.Aspect a -> Bool+          timeoutAspect IK.Timeout{} = True+          timeoutAspect _ = False+          hurtEffect :: IK.Effect -> Bool+          hurtEffect (IK.Hurt _) = True           hurtEffect _ = False+          notDetail :: IK.Effect -> Bool+          notDetail IK.Explode{} = fullInfo+          notDetail _ = True+          cstore = storeFromC c           active = cstore `elem` [CEqp, COrgan]                    || cstore == CGround && isJust (strengthEqpSlot itemBase)-          splitAE :: Ord a-                  => [Effect.Aspect a] -> (Effect.Aspect a -> Text)-                  -> [Effect.Effect a] -> (Effect.Effect a -> Text) -> [Text]-          splitAE aspects ppA effects ppE =-            let (periodicAs, restAs) = partition periodicAspect $ sort aspects-                (hurtEs, restEs) = partition hurtEffect $ sort effects-            in map ppA periodicAs ++ map ppE hurtEs-               ++ if active-                  then map ppA restAs ++ map ppE restEs-                  else map ppE restEs ++ map ppA restAs+          splitAE :: (Num a, Show a, Ord a)+                  => (a -> Text)+                  -> [IK.Aspect a] -> (IK.Aspect a -> Text)+                  -> [IK.Effect] -> (IK.Effect -> Text)+                  -> [Text]+          splitAE reduce_a aspects ppA effects ppE =+            let mperiodic = find periodicAspect aspects+                mtimeout = find timeoutAspect aspects+                restAs = sort aspects+                (hurtEs, restEs) = partition hurtEffect $ sort+                                   $ filter notDetail effects+                aes = map ppE hurtEs+                      ++ if active+                         then map ppA restAs ++ map ppE restEs+                         else map ppE restEs ++ map ppA restAs+                rechargingTs = T.intercalate (T.singleton ' ')+                               $ filter (not . T.null)+                               $ map ppE $ stripRecharging restEs+                onSmashTs = T.intercalate (T.singleton ' ')+                            $ filter (not . T.null)+                            $ map ppE $ stripOnSmash restEs+                durable = IK.Durable `elem` jfeature itemBase+                periodicOrTimeout = case mperiodic of+                  _ | T.null rechargingTs -> ""+                  Just IK.Periodic ->+                    case mtimeout of+                      Just (IK.Timeout 0) | not durable ->+                        "(each turn until gone:"+                        <+> rechargingTs <> ")"+                      Just (IK.Timeout t) ->+                        "(every" <+> reduce_a t <> ":"+                        <+> rechargingTs <> ")"+                      _ -> ""+                  _ -> case mtimeout of+                    Just (IK.Timeout t) ->+                      "(timeout" <+> reduce_a t <> ":"+                      <+> rechargingTs <> ")"+                    _ -> ""+                onSmash = if T.null onSmashTs then ""+                          else "(on smash:" <+> onSmashTs <> ")"+            in [periodicOrTimeout] ++ aes ++ [onSmash | fullInfo]           aets = case itemAE of             Just ItemAspectEffect{jaspects, jeffects} ->-              splitAE jaspects aspectToSuffix+              splitAE tshow+                      jaspects aspectToSuffix                       jeffects effectToSuffix             Nothing ->-              splitAE (iaspects itemKind) kindAspectToSuffix-                      (ieffects itemKind) kindEffectToSuffix+              splitAE (\d -> maybe "?" tshow $ Dice.reduceDice d)+                      (IK.iaspects itemKind) kindAspectToSuffix+                      (IK.ieffects itemKind) kindEffectToSuffix       in aets ++ features -partItemWs :: Int -> CStore -> ItemFull -> MU.Part-partItemWs count cstore itemFull =-  let (name, stats) = partItem cstore itemFull+-- TODO: use kit+partItemWs :: Int -> Container -> LevelId -> Time -> ItemFull -> MU.Part+partItemWs count c lid localTime itemFull =+  let (name, stats) = partItem c lid localTime itemFull   in MU.Phrase [MU.CarWs count name, stats] -partItemAW :: CStore -> ItemFull -> MU.Part-partItemAW cstore itemFull =-  let (name, stats) = partItem cstore itemFull+partItemAW :: Container -> LevelId -> Time -> ItemFull -> MU.Part+partItemAW c lid localTime itemFull =+  let (name, stats) = partItem c lid localTime itemFull   in MU.AW $ MU.Phrase [name, stats] -partItemWownW :: MU.Part -> CStore -> ItemFull -> MU.Part-partItemWownW partA cstore itemFull =-  let (name, stats) = partItem cstore itemFull+partItemWownW :: MU.Part -> Container -> LevelId -> Time -> ItemFull -> MU.Part+partItemWownW partA c lid localTime itemFull =+  let (name, stats) = partItem c lid localTime itemFull   in MU.WownW partA $ MU.Phrase [name, stats] -itemDesc :: CStore -> ItemFull -> Overlay-itemDesc cstore itemFull =-  let (name, stats) = partItemN True 99 cstore itemFull-      nstats = makePhrase [name, stats MU.:> ":"]+itemDesc :: Container -> LevelId -> Time -> ItemFull -> Overlay+itemDesc c lid localTime itemFull =+  let (name, stats) = partItemN True 99 c lid localTime itemFull+      nstats = makePhrase [name, stats]       desc = case itemDisco itemFull of         Nothing -> "This item is as unremarkable as can be."-        Just ItemDisco{itemKind} -> idesc itemKind+        Just ItemDisco{itemKind} -> IK.idesc itemKind       weight = jweight (itemBase itemFull)       (scaledWeight, unitWeight) =         if weight > 1000@@ -101,11 +160,12 @@         else (tshow weight, "g")       ln = abs $ fromEnum $ jlid (itemBase itemFull)       colorSymbol = uncurry (flip Color.AttrChar) (viewItem $ itemBase itemFull)-      f c = Color.AttrChar Color.defAttr c+      f color = Color.AttrChar Color.defAttr color       lxsize = fst normalLevelBound + 1  -- TODO       blurb =         "D"  -- dummy         <+> nstats+        <> ":"         <+> desc         <+> makeSentence ["Weighs", MU.Text scaledWeight <> unitWeight]         <+> makeSentence ["First found on level", MU.Text $ tshow ln]

@@ -2,11 +2,12 @@ -- No operation in this module involves the state or any of our custom monads. module Game.LambdaHack.Common.ItemStrongest   ( -- * Strongest items-    strengthOnSmash, strengthToThrow, strengthEqpSlot, strengthFromEqpSlot+    strengthOnSmash, strengthCreateOrgan, strengthDropOrgan+  , strengthToThrow, strengthEqpSlot, strengthFromEqpSlot   , strongestSlotNoFilter, strongestSlot, sumSlotNoFilter, sumSkills     -- * Assorted   , totalRange, computeTrajectory, itemTrajectory-  , unknownPrecious, permittedRanged, unknownMelee+  , unknownMelee, allRecharging, stripRecharging, stripOnSmash   ) where  import Control.Applicative@@ -20,16 +21,13 @@  import qualified Game.LambdaHack.Common.Ability as Ability import qualified Game.LambdaHack.Common.Dice as Dice-import Game.LambdaHack.Common.Effect import Game.LambdaHack.Common.Item+import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.ItemKind -dice999 :: Dice.Dice -> Int-dice999 d = fromMaybe 999 $ Dice.reduceDice d- strengthAspect :: (Aspect Int -> [b]) -> ItemFull -> [b] strengthAspect f itemFull =   case itemDisco itemFull of@@ -50,48 +48,76 @@     [x] -> Just x     xs -> assert `failure` (xs, itemFull) -strengthEffect999 :: (Effect Int -> [b]) -> ItemFull -> [b]-strengthEffect999 f itemFull =+strengthEffect :: (Effect -> [b]) -> ItemFull -> [b]+strengthEffect f itemFull =   case itemDisco itemFull of     Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->       concatMap f jeffects     Just ItemDisco{itemKind=ItemKind{ieffects}} ->-      -- Default for unknown power is 999 to encourage experimenting.-      let trav x = St.evalState (effectTrav x (return . dice999)) ()-      in concatMap f $ map trav ieffects+      concatMap f ieffects     Nothing -> []  strengthFeature :: (Feature -> [b]) -> Item -> [b] strengthFeature f item = concatMap f (jfeature item) +-- Simplification: does not take into account effects inside @Recharging@,+-- because @Hurt@, etc., are unlikely to have a timeout. strengthMelee :: ItemFull -> Maybe Int strengthMelee itemFull =   let durable = Durable `elem` jfeature (itemBase itemFull)       p (Hurt d) = [floor (Dice.meanDice d)]       p (Burn k) = [k]       p _ = []-      hasNoEffects = case itemDisco itemFull of+      hasExtraEffects = case itemDisco itemFull of         Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects}} ->-          null jeffects+          any (\ef -> null $ p ef) jeffects         Just ItemDisco{itemKind=ItemKind{ieffects}} ->-          null ieffects-        Nothing -> True-  in if hasNoEffects+          any (\ef -> null $ p ef) ieffects+        Nothing -> False+      -- We assume extra weapon effects are usually useful and so such+      -- weapons are preferred over weapons with the same power, by default.+      -- If the player doesn't like a particular weapon's extra effect,+      -- he has to manage this manually.+      bonusExtraEffects = if hasExtraEffects then 1 else 0+      psum = sum (strengthEffect p itemFull)+  in if psum == 0      then Nothing-     else Just $ sum (strengthEffect999 p itemFull)-                 + if durable then 100 else 0+     else Just $ bonusExtraEffects + psum + if durable then 100 else 0  -- Called only by the server, so 999 is OK.-strengthOnSmash :: ItemFull -> [Effect Int]+strengthOnSmash :: ItemFull -> [Effect] strengthOnSmash =   let p (OnSmash eff) = [eff]       p _ = []-  in strengthEffect999 p+  in strengthEffect p +strengthCreateOrgan :: ItemFull -> [GroupName ItemKind]+strengthCreateOrgan =+  let p (CreateItem COrgan grp _) = [grp]+      p (Recharging (CreateItem COrgan grp _)) = [grp]+      p _ = []+  in strengthEffect p++strengthDropOrgan :: ItemFull -> [GroupName ItemKind]+strengthDropOrgan =+  let p (DropItem COrgan grp _) = [grp]+      p (Recharging (DropItem COrgan grp _)) = [grp]+      p _ = []+  in strengthEffect p+ strengthPeriodic :: ItemFull -> Maybe Int-strengthPeriodic =-  let p (Periodic k) = [k]+strengthPeriodic itemFull =+  let p Periodic = [()]       p _ = []+      isPeriodic = isJust $ strengthAspectMaybe p itemFull+      q (Timeout k) = [k]+      q _ = []+  in if isPeriodic then strengthAspectMaybe q itemFull else Nothing++strengthTimeout :: ItemFull -> Maybe Int+strengthTimeout =+  let p (Timeout k) = [k]+      p _ = []   in strengthAspectMaybe p  strengthAddMaxHP :: ItemFull -> Maybe Int@@ -112,12 +138,18 @@       p _ = []   in strengthAspectMaybe p -strengthAddSkills :: ItemFull -> Maybe Ability.Skills-strengthAddSkills =+strengthAllAddSkills :: ItemFull -> Maybe Ability.Skills+strengthAllAddSkills =   let p (AddSkills a) = [a]       p _ = []   in strengthAspectMaybe p +strengthAddSkills :: Ability.Ability -> ItemFull -> Maybe Int+strengthAddSkills ab =+  let p (AddSkills a) = [fromMaybe 0 $ EM.lookup ab a]+      p _ = []+  in strengthAspectMaybe p+ strengthAddHurtMelee :: ItemFull -> Maybe Int strengthAddHurtMelee =   let p (AddHurtMelee k) = [k]@@ -198,11 +230,12 @@ strengthFromEqpSlot :: EqpSlot -> ItemFull -> Maybe Int strengthFromEqpSlot eqpSlot =   case eqpSlot of-    EqpSlotPeriodic -> strengthPeriodic  -- a very crude approximation+    EqpSlotPeriodic -> strengthPeriodic+    EqpSlotTimeout -> strengthTimeout     EqpSlotAddMaxHP -> strengthAddMaxHP     EqpSlotAddMaxCalm -> strengthAddMaxCalm     EqpSlotAddSpeed -> strengthAddSpeed-    EqpSlotAddSkills -> \itemFull -> sum . EM.elems <$> strengthAddSkills itemFull+    EqpSlotAddSkills ab -> strengthAddSkills ab     EqpSlotAddHurtMelee -> strengthAddHurtMelee     EqpSlotAddHurtRanged -> strengthAddHurtRanged     EqpSlotAddArmorMelee -> strengthAddArmorMelee@@ -237,29 +270,9 @@ sumSkills :: [ItemFull] -> Ability.Skills sumSkills is =   let g itemFull = (Ability.scaleSkills (itemK itemFull))-                   <$> strengthAddSkills itemFull+                   <$> strengthAllAddSkills itemFull   in foldr Ability.addSkills Ability.zeroSkills $ mapMaybe g is -unknownPrecious :: ItemFull -> Bool-unknownPrecious itemFull =-  Durable `notElem` jfeature (itemBase itemFull)  -- if durable, no risk-  && case itemDisco itemFull of-    Just ItemDisco{itemAE=Just _} -> False-    _ -> Precious `elem` jfeature (itemBase itemFull)--permittedRanged :: ItemFull -> Maybe Int -> Bool-permittedRanged itemFull _ =-  let hasEffects = case itemDisco itemFull of-        Just ItemDisco{itemAE=Just ItemAspectEffect{jeffects=[]}} -> False-        Just ItemDisco{itemAE=Nothing, itemKind=ItemKind{ieffects=[]}} -> False-        _ -> True-  in hasEffects-     && not (unknownPrecious itemFull)-     && case strengthEqpSlot (itemBase itemFull) of-          Just (EqpSlotAddLight, _) -> True-          Just _ -> False-          Nothing -> True- unknownAspect :: (Aspect Dice.Dice -> [Dice.Dice]) -> ItemFull -> Bool unknownAspect f itemFull =   case itemDisco itemFull of@@ -274,3 +287,24 @@       p _ = []       f itemFull b = b || unknownAspect p itemFull   in foldr f False++allRecharging :: [Effect] -> [Effect]+allRecharging effs =+  let getRechargingEffect :: Effect -> Maybe (Effect)+      getRechargingEffect e@Recharging{} = Just e+      getRechargingEffect _ = Nothing+  in mapMaybe getRechargingEffect effs++stripRecharging :: [Effect] -> [Effect]+stripRecharging effs =+  let getRechargingEffect :: Effect -> Maybe (Effect)+      getRechargingEffect (Recharging e) = Just e+      getRechargingEffect _ = Nothing+  in mapMaybe getRechargingEffect effs++stripOnSmash :: [Effect] -> [Effect]+stripOnSmash effs =+  let getOnSmashEffect :: Effect -> Maybe (Effect)+      getOnSmashEffect (OnSmash e) = Just e+      getOnSmashEffect _ = Nothing+  in mapMaybe getOnSmashEffect effs